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! All rights reserved. 

! Unauthorized reproduction prohibited. 



! Time-stamp: <98/06/29 14:34:03 ayahil> 



SUBROUTINE Algebron( & 



& abstol, & 
& add_iter, & 
& chi2, & 




& gof, & 



& gof_ev, & 
& gof_std, & 



! Absolute error limit in minimization 
! Flag for adding iterations 
! Chi A 2 at each sampling point 
! Goodness-of-fit measure 
! Expectation value of the GOF measure 
! Standard deviation of the GOF measure 
! # of samples 



& nsig, & ! # of sigma for Lambda truncation 



USE Interfaces, ONLY: Covar, Cull, Func, Get_gof, Next, Sample 
USE Mynr, ONLY: Frprmn, Linmin 
USE Nr, ONLY: Gammq 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Get_diag, Ifirstloc 
USE Parm, ONLY: diagv, idx, iflag, k, n, norm, p, r, sm, w 
USE Utils, ONLY: Permute, Wher 
IMPLICIT NONE 



INTEGER, INTENT(in) :: add_iter, prn, stepmx 
INTEGER, INTENT(in), TARGET :: n_t, p_t 
REAL(sp), INTENT(in) :: abstol, nsig, reltol, signif 
REAL(sp), INTENT(in), TARGET, DIMENSION(nJ) :: w_t 
REAL(sp), INTENT(in), TARGET, DIMENSION(n_t,p_t) :: r_t 
REAL(sp), INTENT(inout), DIMENSION(p_t*(p_t+l)) :: z 
REAL(sp), INTENT(out) :: gof, gof_ev, gof_std 
REAL(sp), INTENT(out), DIMENSION(nJ) :: chi2, prob 
REAL(sp), INTENT(out), DIMENSION(p_t,p_t) :: v 



& p_t, & 
& pm, & 
& prob, & 
& r_t, & 
& reltol, & 
& signif, & 
& stepmx, & 
&v, & 
& w_t, & 
&z& 
&) 



! # of valid securities 
! Print flag 

! Probabilities of chi A 2 array 
! Returns 

! Relative error limit in minimization 

! Significance level for accepting an iteration 



! Maximum # of steps in FRPRMN 
! Resultant covariance matrix 

! Weights 
! Update parameters 



! Arguments 



! Locals 
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INTEGER :: chk, i, it, kmn, kmx, ndx, m, np, nz, ppl 
INTEGER, ALLOCATABLE, DIMENSION(:) :: tdx 
INTEGER, DIMENSION(p_t*(p_t+l)) :: iz 
REAL(sp) :: f, f_old, nd, np_old 
REAL(sp), ALLOCATABLE, DIMENSION(:) :: xi 
REAL(sp), DIMENSION(p_t*(p_t+l)) :: z_old 
REAL(sp), DIMENSION(p_t) :: In, std 

! Initialization & pointers • 

n => n_t 
p=>p_t 
r => r_t 
w => w_t 

IF( ALLOCATED( sm ) ) DEALLOCATE( sm ) 
ALLOCATE( diagv(p), sm(n) ) 
! Check sizes 

chk = Assert_eq( (/ n, SIZE(chi2), SIZE(prob), SIZE(r,l), SIZE(w) /), & 
& ' Algebron-n* ) 

chk = Assert_eq( p, SIZE(r,2), SIZE(v,l), SIZE(v,2) , * Algebron-p' ) 
ppl = Assert_eq( p*(p+l), SIZE(z), * Algebron-z' ) 

! Decrypt input z & determine # of factors 
iz = Permute( ppl, seed=123571 113 ) 
IF( ALL( z = 0.0_sp ) ) THEN 

k = 0 
ELSE 

WHERE( z /= 0.0_sp ) 
z = SIGN( EXP( ABS( z ) ) - iz, z ) 

END WHERE 

k = (ppl - Ifirstloc( z(ppl :1 :-l) /= 0.0_sp ))/p 
END IF 

! Index lists for valid returns by date 
ALLOCATE( tdx(p) ) 
DOi= l,n 

tdx = Wher( r(i,:) /= -999.0_sp, cnt=m ) 

ALLOCATE( sm(i)%idx(m) ) 

sm(i)%idx = tdx(:m) 
END DO 

DEALLOCATE( tdx ) 

! Sampling standard deviations and Lambda 

! noise estimates 
CALL Sample( In, r, std, w ) 

! For k=0 there is no loading matrix, so start 

! with the sig's set to the sampling std 

IF( k = 0 ) THEN 
z(:p) = std 
z(p+l:) = 0.0_sp 
v = Covar( z(:p) ) 
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< t 

END IF 

! Loop on increasing # of factors 
IF(pm/=0) WRITE(V(a)') ' iter steps np LLF & 

& // ' LLF+np gof gof_ev dgotfstd' 
kmn = k 

IF( add_iter /= 0 ) THEN 

kmx = p 
ELSE 

kmx = k 
ENDIF 

k = MAX(k- 1,0) 

Factorjoop: DO WHILE( k < kmx ) 

! Increase the # of factors by 1 

k = k+ 1 
nz = p*k -(- p 

! Initialization & initial printout 
IF( k = kmn .OR. k = 1 ) THEN 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v,w) 
nd = 0.5_sp*gof_ev 
iflag - 1 

f = Func( z(:nz) ) 

np = COUNT( z(:nz) /= 0.0_sp ) 

IF( prn /= 0 ) WRITE(*;(3i8 5 2fl0.3 ? 3fl0.iy) kmn, 0, np, f, f + np, & 
& gof, gof_ev, (gof - gof_ev)/gof_std 
END IF 

! Keep old values in case we have to back up 

fold = f 
np_old = np 
z_old = z 

! Line search along the Lambda direction with 
! the biggest negative curvature (strongest 
! descent direction in the multivariate saddle 
! point); if there is no such .direction exit 
! the factor loop 
IF(k> kmn) THEN 

ALLOCATE( xi(nz) ) 

xi(p*k+l :) = Next( z(:nz) ) 

IF( ALL( xi(p*k+l :) = 0.0_sp ) ) EXIT 

xi(:p*k) = 0.0_sp 

v = Covar( z(:nz) ) 

diagv = Get_diag( v ) 

iflag - 2 

CALL Linmin( z(:nz), xi ; f ) 
DEALLOCATE( xi ) 

! Cull Parameters 
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z(p+l :nz) = Cull( In, nsig, z(p+l :nz) ) 
np = COUNT( z(:nz) /= 0.0_sp ) 

! Rescale 
f = Func( z(:nz) ) 

z(:p) = SQRT( norm/nd )* ABS( z(:p) ) 
END IF 

! The main optimization is done by calling the 
! nonlinear minimization program FRPRMN of 
! Numerical Recipes, as modified by A. Yahil. 
! Rescale the coavariance matrix for the 
! correct chi A 2 before and after the 
! minimization. 

iflag = 1 
it = stepmx 

CALL Frprmn( z(:nz), MAX( abstol, ppl/2*reltol ■), 0.0_sp, it, f ) 

! Cull Parameters 
z(p+l :nz) = Cull( In, nsig, z(p+l :nz) ) 
np = COUNT( z(:nz) /= 0.0_sp ) 

! Rescale 

f = Func( z(:nz) ) 

z(:p) = SQRT( norm/nd )* ABS( z(:p) ) 

! Output 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
f = Func( z(:nz) ) 

IF( prn /= 0 ) WWTE(*,*(3i8,2fl0.3,3fl0.1)') k, it, np, f, f + np, gof, & 
& gof_ev, (gof - gof_ev)/gof_std 

! Run FRPRMN again with the culled Lambda's 
! fixed. 

ALLOCATE( tdx(nz) ) 

tdx = Wher( z(:nz) = 0.0, cnt=ndx ) 

ALLOCATE( idx(ndx) ) 

idx = tdx(:ndx) 

it = stepmx 

CALL Frprmn( z(:nz), MAX(abstol,ppl/2*reltol), 0.0_sp, it, f ) 
DEALLOCATE( idx, tdx ) 
! Rescale 

z(:p) = SQRT( norm/nd )* ABS( z(:p) ) 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
f = Func( z(:nz) ) 

IF( prn /= 0 ) WRITE(*,'(3i8,2fl0.3,3fl0.iy) k, it, np, f, f + np, gof, & 
& gof_ev, (gof - gof_ev)/gof_std 

! Back up to the previous solution if the 

! improvement in LLF is not significant at the 

! prescribed significance level, or there is 
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! no increase in the # of parameters 
IF( k > kmn .AND. ( np <= np_old .OR. f >= f old & 

& .OR. Gammq( 0.5_sp*ABS(np - np_old + EPSILON(1.0_sp)), & 
& 0.5_sp*ABS(f_old - f) ) > signif ) ) THEN 
IF(prn/=0) WRITE(*,*)& 

The last iteration was rejected as insignificant' 
k = k- 1 
nz = nz - p 
z(:nz) = z_old(:nz) 
z(nz+l:) = 0.0_sp 
v - Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
np = COUNT( z(:nz) /= 0.0_sp ) 
EXIT 
END IF 
END DO Factorjoop 

! Encrypt nonzero z's 
WHERE(z/=0.0_sp) 

z = SIGN( LOG( iz + ABS( z ) ), z ) 
END WHERE 

! Cleanup 
DEALLOCATE( diagv ) 

END SUBROUTINE Algebron 
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/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

/* Time-stamp: <98/07/24 07:52:46 ayahil> */ 

/* 

Estimates the covariance matrix V(P,P) using the Algebron (TM) method which 
minimizes the complexity of V. See the variable list for specifics. Note 
that the input/output variable Z is set to zero for computations from 
scratch; otherwise the result of the previous computation needs to be 
provided. 

.*/ 

#ifhdef ALGEBRON_H 
#define ALGEBRON_H 

void algebron_( 

double* abstol, /* Absolute convergence criterion in 
Maximum-likelihood minimization. Input 
[default=0.01] */ 
int* add_iter, /* Flag to add iterations. Zero: do not add, 
nonzero: add. Input */ 
double* chi2, /* Chi-squared of sampled variables as a 

function of time. Output array(n) */ 
double* gof, /* Goodness-of-fit estimaor. Output */ 
double* gof_ev, /* Expectation Value of GOF estimator. 

Output */ 

double* gof_std, /* Standard deviation of GOF estimator. 

Output */ 

int* n, /* Total # of security samplings. Input */ 

double* nsig, /* Number of sigma's below which a parameter is 

culled. Input [default=3]*/ 
int* p, /* Number of valid returns. Input */ 
int* prn, /* Print flag. Zero: do not print, nonzero: 

print. Input [default=l] */ 
double* prob, /* Probabilities of the chi-squared array. 
Output array(n) */ 
double* r, /* valid returns. Input array(n,p) */ 
double* reltol, /* Relative (to p*(p+l)/2) convergence 

criterion in maximum-likelihood 

minimization. Input [default=0.0001] */ 
double* signif, /* Significance level at which to accept a new 

iteration. Input [default=0.01] */ 



[algebron.h] 



int* stepmx, /* Maximum number of computation steps per 
iteration. Input [default=100] */ 

double* v, /* Estimated covariance matrix. Output 
array(p 5 p) */ 

double* w, /* Time weighting of the securities in the 
computation of the covariance matrix. Input 
array(n) */ 

double* z /* Update parameters. Input/Output 
array(p*(p+l)) */ 

); 

double abstol_def = 0.01; 
int add_iter_def = 1 ; 
double nsig_def = 3.0; 
int prn_def = 1 ; 
double reltol_def = 0.0001; 
double signif_def = 0.01; 
int stepmx_def= 100; 
#endif 
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/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

I* ***************************************** *j 

/* Time-stamp: <98/07/08 09:36:43 ayahil> */ 

/* 

Mother of all ALGEBRON includes 
*/ 

#ifiidef ALGEBRONALLH 
#define ALGEBRON ALL H 

#include "algebron.h" 
#include "bootstrap.h" 
#include "gen_covar.h" 
#include "gen_dev.h" 
#include "prepare.h" 

#endif 
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*************************************** 



Copyright (C) 1998 by Algebron LLC. 
All rights reserved. 

Unauthorized reproduction prohibited. 



*************************************** 



! Time-stamp: <98/06/29 14:26:17 ayahil> 
SUBROUTINE Algebron( & 



USE Interfaces, ONLY: Covar, Cull, Func, Get_gof, Next, Sample 
USE Mynr, ONLY: Frprmn, Linmin 
USE Nr, ONLY: Gammq 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Getjiiag, Ifirstloc 
USE Parm, ONLY: diagv, idx, iflag, k, n, norm, p, r, sm, w 
USE Utils, ONLY: Permute, Wher 
IMPLICIT NONE 



INTEGER, INTENT(in) :: add_iter, prn, stepmx 
INTEGER, INTENT(in), TARGET :: nj, p_t 
REAL(sp), INTENT(in) :: abstol, nsig, reltol, signif 
REAL(sp), INTENT(in), TARGET, DIMENSION(nJ) :: w_t 
REAL(sp), INTENT(in), TARGET, DIMENSION(n_t,p_t) :: r_t 
REAL(sp), INTENT(inout), DIMENSION(p_t*(p_t+l)) :: z 
REAL(sp), INTENT(out) :: gof, gof_ev, gofjstd 
REAL(sp), INTENT(out), DIMENSION(nJ) :: chi2, prob 
REAL(sp), INTENT(out), DIMENSION(pJ,p_t) :: v 



& abstol, & 
& add_iter, & 
& chi2, & 
& gof, & 
& gof_ev, & 
& gof_std, & 
& n_t, & 
& nsig, & 
& p_t, & 
& prn, & 
& prob, & 
& r_t, & 
& reltol, & 
& signif, & 
& stepmx, & 
& v, & 
& w_t, & 
& z& 
&) 



! Relative error limit in minimization 
! Significance level for accepting an iteration 
! Maximum # of steps in FRPRMN 

! Resultant covariance matrix 
! Weights 

! Update parameters 



! Absolute error limit in minimization 
! Flag for adding iterations 

! Chi A 2 at each sampling point 

! Goodness-of-fit measure 
! Expectation value of the GOF measure 
! Standard deviation of the GOF measure 

! # of samples 

! # of sigma for Lambda truncation 
! # of valid securities 
! Print flag 

! Probabilities of chi A 2 array 
! Returns 



! Arguments 



! Locals 
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INTEGER :: chk, i, it, kmn, kmx, ndx, m, np, nz, ppl 
INTEGER, ALLOCATABLE, DIMENSION(:) :: tdx 
INTEGER, DIMENSION(p_t*(p_t+l)) :: iz 
LOGICAL, SAVE :: license_verified=.FALSE. 
REAL(sp) :: f, f_old, nd, np_old 
REAL(sp), ALLOCATABLE, DIMENSION(:) :: xi 
REAL(sp), DIMENSION(p_t*(p_t+l)) :: z_old 
REAL(sp), DIMENSION(p_t) :: In, std 

! Externals 
INTEGER Vlslicense 

! Check for valid license 
IF( .NOT. license_verified ) THEN 
IF ( Vlslicense( "LibAlgebron" // CHAR(O), "0" // CHAR(O) ) = 1) THEN 
license_verified = .TRUE. 
WRITE(*,*) 'Valid license' 
ELSE 

WRITE(*,*) *No Valid license: cannot execute the ALGEBRON routine.' 
!!$ RETURN 

ENDIF 
END IF 

! Initialization & pointers 

n => n_t 
p=>p_t 
r => r_t 
w => w_t 

IF( ALLOCATED( sm ) ) DEALLOCATE( sm ) 
ALLOCATE( diagv(p), sm(n) ) 
! Check sizes 

chk = Assert_eq( (/ n, SIZE(chi2), SIZE(prob), SIZE(r,l), SIZE(w) I), & 
& ' Algebron-n' ) 

chk = Assert_eq( p, SIZE(r,2), SIZE(v,l), SIZE(v,2) , ' Algebron-p' ) 
ppl = Assert_eq( p*(p+l), SIZE(z), ' Algebron-z' ) 

! Decrypt input z & determine # of factors 
iz = Permute( ppl, seed=123571113 ) 
IF( ALL( z = 0.0_sp ) ) THEN 

k = 0 
ELSE 

WHERE(z/=0.0_sp) 
z = SIGN( EXP( ABS( z ) ) - iz, z ) 

END WHERE 

k = (ppl - Ifirstloc( z(ppl : 1 :-l) /= 0.0_sp ))/p 
ENDIF 

! Index lists for valid returns by date 
ALLOCATE( tdx(p) ) 
DO i = l,n 
tdx = Wher( r(i,:) /= -999.0_sp, cnt=m ) 
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ALLOCATE( sm(i)%idx(m) ) 
sm(i)%idx = tdx(:m) 
END DO 

DEALLOCATE( tdx ) 

! Sampling standard deviations and Lambda 

! noise estimates 
CALL Sample( In, r, std, w ) 

! For k=0 there is no loading matrix, so start 

! with the sig's set to the sampling std 

IF( k = 0 ) THEN 

z(:p) = std 

z(p+l;) = 0.0_sp 

v = Covar( z(:p) ) 
END IF 

! Loop on increasing # of factors 
IF(prn/=0) WRITECV(a)') ' iter steps np LLF & 

&//' LLF+np gof gof_ev dgof/std' 
kmn = k 

IF( add_iter/=0)THEN 

kmx = p 
ELSE 

kmx = k 
ENDIF 

k = MAX(k- 1,0) 

Factorjoop: DO WHILE( k < kmx ) 

! Increase the # of factors by 1 

k = k+l 
nz = p*k + p 

! Initialization & initial printout 
IF( k = kmn .OR. k = 1 ) THEN 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
nd = 0.5_sp*gof_ev 
iflag =1 

f = Func( z(:nz) ) 

np = COUNT( z(:nz) /= 0.0_sp ) 

IF( prn /= 0 ) WRITE(*/(3i8,2fl0.3,3fl0.1)') kmn, 0, np, f, f + np, & 
& gof, gof_ev, (gof - gofev)/gof_std 
END IF 

! Keep old values in case we have to back up 

f_old = f 
np_old = np 
z_old = z 

! Line search along the Lambda direction with 
! the biggest negative curvature (strongest 
! descent direction in the multivariate saddle 
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! point); if there is no such direction exit 

! the factor loop 
IF( k > kmn ) THEN 
ALLOCATE( xi(nz) ) 
xi(p*k+l:) = Next( z(:nz)) 
IF( ALL( xi(p*k+l :) = 0.0_sp ) ) EXIT 
xi(:p*k) - 0.0_sp 
v = Covar( z(:nz) ) 
diagv = Get__diag( v ) 
iflag = 2 

CALL Linmin( z(:nz), xi, f ) 
DEALLOCATE( xi ) 

! Cull Parameters 
z(p+l:nz) = Cull( In, nsig, z(p+l:nz) ) 
np = COUNT( z(:nz) /= 0.0_sp ) 

! Rescale 
f = Func( z(:nz) ) 

z(:p) = SQRT( norm/nd )*ABS( z(:p) ) 
END IF 

! The main optimization is done by calling the 
! nonlinear minimization program FRPRMN of 
! Numerical Recipes, as modified by A. Yahil. 
! Rescale the coavariance matrix for the 
! correct chi A 2 before and after the 
! minimization. 

iflag = 1 
it = stepmx 

CALL Frprmn( z(:nz), MAX( abstol, ppl/2*reltoI ), 0.0_sp, it, f ) 

! Cull Parameters 
z(p+l :nz) = Cull( In, nsig, z(p+l :nz) ) 
np = COUNT( z(:nz) /= 0.0_sp ) 

! Rescale 

f = Func( z(:nz) ) 

z(:p) = SQRT( norm/nd )* ABS( z(:p) ) 

! Output 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r,v,w) 
f = Func( z(:nz) ) 

IF( prn /= 0 ) WRITE(*, , (3i8,2fl0.3,3fl0.1)') k, it, np, f, f + np, gof, & 
& gof_ev, (gof - gof_ev)/gof_std 

! Run FRPRMN again with the culled Lambda's 
! fixed. 

ALLOCATE( tdx(nz) ) 

tdx = Wher( z(:nz) = 0.0, cnt=ndx ) 

ALLOCATE( idx(ndx) ) 

idx = tdx(:ndx) 
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it = stepmx 

CALL Frprmn( z(:nz), MAX(abstol,ppl/2*reltol), 0.0_sp, it, f ) 
DEALLOCATE( idx, tdx ) 
! Rescale 

z(:p) = SQRT( norm/nd )*ABS( z(:p) ) 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
f = Func( z(:nz) ) 

IF( prn /= 0 ) WRITE(*,'(3i8,2fl0.3,3fl0.1)') k, it, np, f, f + np, gof, & 
& gof_ev, (gof - gof_ev)/gof_std 

! Back up to the previous solution if the 
! improvement in LLF is not significant at the 
! prescribed significance level, or there is 
! no increase in the # of parameters 
IF( k > kmn .AND. ( np <= np_old .OR. f >= f_old & 

& .OR. Gammq( 0.5_sp*ABS(np - np_old + EPSILON(1.0_sp)), & 
& 0.5_sp*ABS(f_old - f) ) > signif ) ) THEN 
IF(prn/=0) WRITE(V)& 

'The last iteration was rejected as insignificant' 
k = k- 1 
nz = nz - p 
z(:nz) = z_old(:nz) 
z(nz+l:) = 0.0_sp 
v = Covar( z(:nz) ) 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) 
np = COUNT( z(:nz) /= 0.0_sp ) 
EXIT 
END IF 
END DO Factorjoop 

! Encrypt nonzero z's 
WHERE(z/=0.0_sp) 

z = SIGN( LOG( iz + ABS( z ) ), z ) 
END WHERE 

! Cleanup 
DEALLOCATE( diagv ) 

END SUBROUTINE Algebron 
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************************************** 



! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited, 
i************************************** 

! Time-stamp: <98/07/24 07:57:09 ayahil> 
!! ! Generate a bootstrap frequency distribution (with repetitions). 

SUBROUTINE Bootstrap( & 

& freq, & ! Bootstrap frequency distribution 

& n, & ! # of bootstrap samples 

& seed & ! Initial seed for random number generator 

&) 

USE Drport, ONLY: Time 

USE Nr, ONLY: Rani ' \ 

USE Nrtype 

USE Ran_state, ONLY: Ran_seed 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: n, seed 
INTEGER, INTENT(out), DIMENSION(n) :: freq 

! Locals 

INTEGER :: i 

INTEGER, DIMENSION(n) :: j 
LOGICAL, SAVE :: firsttime=. TRUE. 
REAL(sp), DIMENSION(n) :: t 

! Set the random number seed in the first call 
! to this subroutine— 0: use Time(), 
! otherwise: use given seed. 
IF( firsttime ) THEN 
firsttime = .FALSE. 
IF( seed = 0 ) THEN 

CALL Ran_seed( Time() ) 
ELSE 

CALL Ran_seed( seed ) 
END IF 
END IF 

! Random frequency 

CALL Ranl( t ) 
j = INT( t*n ) + 1 
freq = 0 
DOi= l,n 

freqG(i)) = freqO(i))+l 
END DO 
END 
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/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

***************************************** */ 



/* Time-stamp: <98/07/24 07:57:28 ayahil> */ 



Generate a bootstrap frequency distribution (with repetitions). 



#ifhdef BOOTSTRAPS 
#define BOOTSTRAPH 

void bootstrap_( 

int* freq, /* Bootstrap frequency distribution. Output 
array(n) */ 



*/ 



int* n, 
int* seed 



/* Total # of samples. Input */ 

/* Initial seed for random number generator. 

Zero: use clock, otherwise: use input seed. 

Input [default=0] */ 



); 



int seed_def = 0; 



#endif 
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! Copyright (C) 1997 by Amos Yahil. 

! All Rights Reserved. < 

! Based on (C) Numerical Recipes software, 
i******************************************** 

! Time-stamp: <97/03/28 13:03:19 ayahil> 
FUNCTION brent(ax,bx,cx,func,tol,xmin) 
USE nrtype; USE nrutil, ONLY : nrerror 
IMPLICIT NONE 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: brent 
INTERFACE 
FUNCTION func(x,dx) 

USE nrtype 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: x 

REAL(SP), OPTIONAL, INTENT(OUT) :: dx 

REAL(SP) :: tunc 
END FUNCTION func 
END INTERFACE 

INTEGER(I4B), PARAMETER :: ITMAX=100 

REAL(SP), PARAMETER :: CGOLD=0.3819660_sp,ZEPS=1.0e-3_sp*EPSILON(ax) 
INTEGER(I4B) :: iter 

REAL(SP) :: a,b4,e,etemp,ru,rv,fw,fx,p,q,r,toll,tol2,u,v,w,x,xm 

a=MIN(ax,cx) 

b=MAX(ax,cx) 

v=bx 

w=v 

x=v 

e=0.0 

fx=func(x) 

fv=fx 

fw=fx 

DOiter=l,ITMAX 
xm=0.5_sp*(a+b) 
toll=tol*ABS(x)+ZEPS 
tol2=2.0_sp*toll 

IF (ABS(x-xm) <= (tol2-0.5_sp*(b-a))) THEN 

xmin=x 

brent=fx 

RETURN 
END IF 

IF (ABS(e)> toll) THEN 
r=(x-w)*(fx-fv) 
q=(x-v)*(fx-fw) 
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p=(x-v)*q-(x-w)*r 

q=2.0_sp*(q-r) 

IF (q > 0.0) p=-p 

q=ABS(q) 

etemp=e 

e=d 

IF (ABS(p) >= ABS(0.5_sp*q*etemp) .OR. & 
p <= q*(a-x) .OR. p >= q*(b-x)) THEN 
e=MERGE(a-x,b-x, x >= xm ) 
d=CGOLD*e 

else' 

d=p/q 
u=x+d 

IF (u-a < tol2 .OR. b-u < tol2) d=SIGN(toll,xm-x) 
END IF 
ELSE 

e=MERGE(a-x,b-x, x >= xm ) 
d=CGOLD*e 
END IF 

u=MERGE(x+d,x+SIGN(toll,d), ABS(d) >= toll ) 
fu=func(u) 
IF (fa <= fx) THEN 
IF (u >= x) THEN 

a=x 
ELSE 
b=x 
END IF 

CALL shft(v,w,x,u) 
CALL shft(fV,fw,fx,fa) 
ELSE 
IF (u < x) THEN 

a=u 
ELSE 

b=u 
END IF 

IF (fu <= fw .OR. w = x) THEN 
v=w 
fv=fw 
w=u 
fw=fu 

ELSE IF (fu <= fv .OR. v = x .OR. v = w) THEN 
v=u 
fv=fu 
END IF 
END IF 
END DO 
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CALL nrerror('brent: exceed maximum iterations') 
CONTAINS 

!BL 

SUBROUTINE shft(a,b,c,d) 
REAL(SP), INTENT(OUT) :: a 
REAL(SP), INTENT(INOUT) :: b,c 
REAL(SP), INTENT(IN) :: d 
a=b 
b=c 
c=d 

END SUBROUTINE shft 
END FUNCTION brent 
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SUBROUTINE choldc(a,p) 

USE nrtype; USE nrutil, ONLY : assert_eq,nrerror 

IMPLICIT NONE 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 
REAL(SP), DIMENSIONC), INTENT(OUT) :: p 
INTEGER(I4B) :: i,n 
REAL(SP) :: summ 

n=assert_eq(size(a, 1 ),size(a,2),size(p),'choldc') 
do i=l,n 

summ=a(i,i)-dot_product(a(i, 1 :i- 1 ),a(i, 1 :i- 1 )) 
if (summ <= 0.0) call nrerror('choldc failed') 
p(i)=sqrt(summ) 

a(i+l :n,i)=(a(i,i+l :n)-matmul(a(i+l :n,l :i-l),a(i,l :i-l)))/p(i) 

end do 

END SUBROUTINE choldc 
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***************************************** 

Copyright (C) 1998 by Algebron LLC. 
All rights reserved. 

Unauthorized reproduction prohibited. 
**************** 

Time-stamp: <98/06/26 21:17:31 ayahil> 



! ! ! Inverse of a symmetric, positive-definite, matrix using the Cholesky 

! ! ! decomposition. This routine assumes that the decomposition has been 

! ! ! performed by Numerical Recipes routine CHOLDC, whose output is used for 

! ! ! the matrix inversion. The output variables are both optional: ainv 

! ! ! returns the full inverse matrix, diag only the diagonal part. 



SUBROUTINE Cholinv( & 

& a, & ! Input matrix as outputted by CHOLDC 

& p, & ! Input diagonal as outputted by CHOLDC 

& ainv, & ! Resultant inverse matrix 

& diag & ! Resultant diagonal of inverse matrix 

&) 



USE Nrtype 

USE Nrutil, ONLY : Assert_eq, Get_diag 
! Arguments 

IMPLICIT NONE 

REAL(sp), INTENT(in), DIMENSION(:,:) :: a 
REAL(sp), INTENT(in), DIMENSION(:) :: p 

REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l),SIZE(a,2)) :: ainv 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l)) :: diag 
! Locals 

INTEGER:: i,j, n 

REAL(sp), DIMENSION(SIZE(a,l)) :: x 
! Check sizes 

n = Assert_eq( SIZE(a,l), SIZE(a,2), SIZE(p), ' Cholinv' ) 
IF( PRESENT(ainv) ) THEN 

n = Assert_eq( n, SIZE(ainv,l), SIZE(ainv,2), ' Cholinv' ) 
END IF 

IF( PRESENT(diag) ) THEN 

n = Assert_eq( n, SIZE(diag), ' Cholinv 1 ) 
END IF 

! Matrix inversion 
IF( PRESENT(ainv) ) THEN 
DOj = l,n 
xG)=1.0_sp/p(j) 
DOi=j+l,n 

x(i) = - DOT_PRODUCT(a(ij:i-l),xG:i-l))/p(i) 
END DO 
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D0i = nj,-1 

x(i) = (x(i) - DOT_PRODUCT(a(i+l :,i),x(i+l :)))/p(i) 
END DO 
DOi=j-l,l,-l 

x(i) = - DOT_PRODUCT(a(i+l:,i),x(i+10)/p(i) 
END DO 
ainv(: j) = x 
END DO 

IF( PRESENT(diag) ) THEN 

diag = Get_diag( ainv ) 
END IF 

ELSE IF( PRESENT(diag) ) THEN 
DOj = l,n 
x(j)=1.0_sp/p0) 
DOi=j+l,n 

x(i) = - DOT_PRODUCT(a(ij:i-l),x(j:i-i))/p(i) 
END DO 
DO i = nj,-l 

x(i) = (x(i) - DOT_PRODUCT(a(i+l:,i),x(i+l:)))/p(i) 
END DO 
diag(j) = x(j) 
END DO 
END IF 

END SUBROUTINE Cholinv 
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SUBROUTINE cholsl(a,p,b,x) 

USE nrtype; USE nrutil, ONLY : assert_eq 

IMPLICIT NONE 

REAL(SP), DIMENSION(:,:), INTENT(IN) :: a 
REAL(SP), DIMENSIONC), INTENT(IN) :: p,b 
REAL(SP), DIMENSION^, INTENT(INOUT) :: x 
INTEGER(I4B) :: i,n 

n=assert_eq((/size(a,l),size(a,2),size(p),size(b),size(x)/),'cholsr) 
do i=l,n 

x(i)=(b(i)-dot_product(a(i, 1 :i- 1 ),x( 1 :i- 1 )))/p(i) 

end do 
do i=n,l,-l 

x(i)=(x(i)-dot_product(a(i+l :n,i),x(i+l :n)))/p(i) 

end do 

END SUBROUTINE cholsl 
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***************************************** 



! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

) ****** ************** + + + * + + * + + 

! Time-stamp: <98/06/26 21:11:34 ayahil> 

! ! Log-likelihood function and its gradient wrt to sig & lambda for factor 
! ! analysis with missing data. Called by the minimization routine Frprmn. 
! ! NOTE: In this routine V is the *reduced* covariance matrix. 



FUNCTION Cml( & 

& lambda, & ! Loading matrix 

& sig, & ! Independent standard deviations 

& dlambda & ! Derivative of function wrt lambda 

& ) RESULT( out ) 



USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Diagadd, Get_diag, Outerprod 
USE Parm, ONLY: diagv, k, n, p, r, sm, w 
USE Utils, ONLY: DmatmulJ, Dmatmul_r, Spd 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: sig 
REAL(sp), INTENT(in), DIMENSION(:,:) :: lambda 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(p,k) :: dlambda 
REAL(sp) :: out 

! Locals 
INTEGER :: chk, i, m 

INTEGER, DIMENSIONC), POINTER :: idx 
REAL(sp) :: dnorm, ldet 

REAL(sp), ALLOC ATABLE, DIMENSION(:) :: b, x 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: vinv 
REAL(sp), DIMENSION^) :: dsig 
REAL(sp), DIMENSION(p,p) :: v 

! Check sizes 
chk = Assert_eq( k, SIZE(lambda,2), ' Cml-k' ) 
chk = Assert_eq( n, SIZE(r,l), SIZE(sm), SIZE(w), ' Cml-n' ) 
chk = Assert_eq( (/ p, SIZE(lambda,l), SIZE(r,2), SIZE(sig), SIZE(v,l), & 

& SIZE(v,2) f), ' Cml-p* ) 
IF( PRESENT( dlambda) ) THEN 

chk = Assert_eq( k, SIZE(dlambda,2), ' Cml-k' ) 

chk = Assert_eq( p, SIZE(dlambda,l), ' Cml-p' ) 
END IF 

! Initialization 

out = 0.0_sp 
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IF( PRESENT(dlambda) ) THEN 

dsig = 0.0_sp 

dlambda = 0.0_sp 
END IF 

v = MATMUL( lambda, TRANSPOSE(lambda) ) 
CALL Diagadd( v, 1.0_sp ) 

! Log-likelihood function 
Datajoop: DOi= l,n 
idx => sm(i)%idx 
m = SIZE(idx) 
IF( m > 0 ) THEN 
ALLOCATE( b(m), x(m) ) 
b = r(i,idx)/sig(idx) 
IF( PRESENT(dlambda) ) THEN 
ALLOCATE( vinv(m,m) ) . 

CALL Spd( v(idx,idx), ainv=vinv, b=b, ldet=ldet, x=x ) 
dlambda(idx,:) = dlambda(idx,:) & 

& + w(i)*MATMUL( vinv - Outerprod( x, x ), lambda(idx,:) ) 
dsig(idx) = dsig(idx) + w(i)*(1.0_sp - b*x) 
DEALLOCATE( vinv ) 
ELSE 

CALL Spd( v(idx,idx), b=b, ldet=ldet, x=x ) 
END IF 

dnorm = DOT_PRODUCT( b, x ) 
DEALLOCATE( b, x ) 

out = out + w(i)*(ldet + dnorm + SUM( LOG( sig(idx)**2 ) )) 
END IF 
END DO Datajoop 

! Optional gradient of likelihood function, 
! including penalty function 
IF( PRESENT(dlambda) ) THEN 
dlambda = 2.0_sp*(dlambda - lambda* (SPREAD( dsig/(1.0_sp & 
& + SUM( lambda**2, DIM=2 )), DIM=2, NCOPIES=k ))) 
END IF 

END FUNCTION Cml 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/22 06:33:30 ayahil> 

! ! ! Covariance matrix from its factor representation. The variables are 
! ! ! passed as a 1-d array, for reasons of convenience in ALGEBRON. 

FUNCTION Covar( & 

& z & ! Minimization array 

& ) RESULT( out ) 

USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Diagadd 
USE Parm, ONLY: k, p 
USE Utils, ONLY: DmatmulJ, Dmatmul_r 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), DIMENSION(p,p) :: out 

! Locals 

INTEGER :: chk 

REAL(sp), DIMENSION^) :: sig 
REAL(sp), DIMENSION(p,k) :: lambda 

! Check sizes 
chk = Assert_eq( p*(k+l), SIZE(z), ' Covar-z' ) 

! Initialization 
lambda = RESHAPE( z(p+l :), SHAPE(lambda) ) 
sig = z(:p) 

! Covariance matrix 
out = MATMUL( lambda, TRANSPOSE(lambda) ) 
CALL Diagadd( out, 1 .0_sp ) 
out = Dmatmul_r( Dmatmul_l( sig, out ), sig ) 

END FUNCTION Covar 
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I***************************************** 

! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 17:03:03 ayahil> 

! ! ! Cull the loading matrix by truncating all elements below NSIG sigma's. 
!!! The loading matrix is passed as a 1-d array, for reasons of convenience in 
!!! ALGEBRON. 

FUNCTION Cull( & 

& In, & ! Effective # of sampling points 

& nsig, & ! SNR at which to truncate 

&z& ! Minimization variables as single 1-d array 

& ) RESULT( out ) 

USE Nrtype 

USE Nrutil, ONLY: Assert_eq 
USE Parm, ONLY: k, p 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in) :: nsig 
REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), INTENT(in), DIMENSION^ :: In 
REAL(sp), DIMENSION(p*k) :: out 

! Locals 

INTEGER :: chk 

! Check sizes 
chk = Assert_eq( p, SIZE(ln), ' Cull-p" ) 
chk = Assert_eq( p*k, SIZE(z), * Cull-z' ) 

! Cull 

WHERE( ABS( z )*RESHAPE( SPREAD( In, DIM=2, NCOPIES=k ), SHAPE(z) ) & 
& < nsig ) 

out = 0.0_sp 
ELSEWHERE 

out = z 
END WHERE 

END FUNCTION Cull 
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MODULE Dflib 

INTERFACE 
SUBROUTINE Getarg( n, buffer ) 
INTEGER :: n 
CHARACTER* (*) :: buffer 
END SUBROUTINE Getarg 
END INTERFACE 

END MODULE Dflib 
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I***************************************** 

! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/10 19:19:02 ayahil> 

!!! Holding place for Unix intrinsic functions ported over to Digital FORTRAN 
!!!forNT. 

MODULE Dfport 

INTEGER :: large, Time 
REAL :: Dtime 

EXTERNAL Dtime, large, Time 
END MODULE Dfport 
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] ***************************************** 

! Copyright (C) 1998 by Algebron LLC. 
! All rights reserved. 

! Unauthorized reproduction prohibited. 

\ *********************************** ****++ 

! Time-stamp: <98/05/06 10:45:45 ayahil> 

! ! ! Matrix multiplication when one of the matrices is a diagonal matrix. 

FUNCTION Dmatmul_l( & 

& diag, & ! Left diagonal matrix 

& mat & ! Right full matrix 

&) RESULT(out) 

USENrtype. 

USE Nrutil, ONLY: Assert_eq 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: diag 
REAL(sp), INTENT(in), DIMENSION(:,:) :: mat 
REAL(sp), DIMENSION(SIZE(diag),SIZE(mat,2)) :: out 

! Locals 

INTEGER :: n 

! Check sizes 

n = Assert_eq( SIZE(diag), SIZE(mat,l), ' Diag_matmul_l' ) 
! Product 

out = SPREAD(diag,2,SIZE(diag)) * mat 

END FUNCTION DmatmulJ 

FUNCTION Dmatmul_r( & 

& mat, & ! Left full matrix 

& diag & ! Right diagonal matrix 

& ) RESULT( out ) 

USE Nrtype 

USE Nrutil, ONLY: Assert_eq 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION^) :: diag 
REAL(sp), INTENT(in), DIMENSION(:,:) :: mat 
REAL(sp), DIMENSION(SIZE(mat,l),SIZE(diag)) :: out 

! Locals 

INTEGER :: n 

! Check sizes 

n = Assert_eq( SIZE(mat,2), SIZE(diag), ' Diag_matmul_r' ) 
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! Product 

out = mat * SPREAD(diag,l,SIZE(diag)) 
END FUNCTION Dmatmul r 



[dmatmul.reO] 



SUBROUTINE eigsrt(d,v) 

USE nrtype; USE nrutil, ONLY : assert_eq,imaxloc,swap 
IMPLICIT NONE 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: d 
REAL(SP), DIMENSION^:), INTENT(INOUT) :: v 
INTEGER(I4B) :: ij,n 

n=assert_eq(size(d),size(v, 1 ),size(v,2),'eigsrt') 
do i=l,n-l 

j=imaxloc(d(i : n))+i- 1 

if(j/=i)then 

call swap(d(i),dO)) 
call swap(v(:,i),v(: j)) 

end if 

end do 

END SUBROUTINE eigsrt 
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*************************************+++++++ 

Copyright (C) 1997 by Amos Yahil. 
All Rights Reserved. 

Based on (C) Numerical Recipes software. 

******************************** **** + m + + *4,* 

Time-stamp: <98/06/29 14:29:17 ayahil> 

!!! Nonlinear minimization routine of Numerical Recipes with corrections by A. 
!!! Yahil. 

SUBROUTINE Frprmn( p, abstol, reltol, iter, fret, lop, hip, ipr ) 
USE Mynr, ONLY: Linrnin 

USE Nrtype; USE Nrutil, ONLY: Assert_eq, Nrerror 

IMPLICIT NONE 

INTEGER, INTENT(inout) :: iter 

INTEGER, OPTIONAL, INTENT(in) :: ipr 

REAL(sp), INTENT(in) :: abstol,reltol 

REAL(sp), INTENT(inout), DIMENSION(:) :: p 

REAL(sp), INTENT(out) :: fret 

REAL(sp), OPTIONAL, INTENT(in), DIMENSION(:) :: hip,lop 
INTERFACE 
FUNCTION func(p,xi) 

USE nrtype 

IMPLICIT NONE 

REAL(sp), INTENT(inout), DIMENSION(:) :: p 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(p)) :: xi 
REAL(sp) :: func 
END FUNCTION func 
END INTERFACE 
INTEGER:: i,itmax,its 
REAL(sp) :: dgg,dx,fp,gam,gg 
REAL(sp), DIMENSION(SIZE(p)) :: g,h,xi 

! Check that limits are not exceeded 
IF( PRESENT(lop) ) THEN 
its = Assert_eq( SIZE(p), SIZE(lop), ' Frprmn-lop' ) 
IF( MINVAL(p-lop) < 0.0 ) THEN 
WRITE(0,*) p 

CALL Nrerror( ' Frprmn: p < lop' ) 
END IF 
END IF 

IF( PRESENT(hip) ) THEN 
its = Assert_eq( SIZE(p), SIZE(hip), ' Frprmn-hip' ) 
IF( MAXVAL(p-hip) > 0.0 ) THEN 
WRITE(0,*) p 

CALL Nrerror( ' Frprmn: p > hip' ) 
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END IF 
END IF 

[Initial function and gradient 

fret = Func( p, xi ) 

!If at limit, don't allow gradient to push out 
IF( PRESENT(lop) ) THEN 
WHERE (p = lop .AND. xi > 0.0) 

xi = 0.0 
END WHERE 
END IF 

IF( PRESENT(hip) ) THEN 

WHERE (p = hip .AND. xi < 0.0) 
xi = 0.0 

END WHERE 
END IF 

! Initial conjugate gradient in the direction 
! of the gradient 

g = -xi 
h = g 
xi = h 

llteration loop 

itmax = iter 
iter = 1 

IF( ALL(xi = 0.0) ) RETURN 
Iterationjoop: DO WHILE(iter <= itmax) 

ISave previous function value 

fp = fret 

!Line minimization 
dx = 1.0_sp/SQRT( DOT_PRODUCT( xi, xi ) ) 
IF( PRESENT(lop) ) THEN 
IF( PRESENT(hip) ) THEN 

CALL Linmin( p, xi, fret, dx=dx, lop=lop, hip=hip ) 
ELSE 

CALL Linmin( p, xi, fret, dx=dx, lop=lop ) 
END IF 

ELSE IF( PRESENT(hip) ) THEN 

CALL Linmin( p, xi, fret, dx=dx, hip=hip ) 
ELSE 

CALL Linmin( p, xi, fret, dx=dx ) 
END IF 

! Optional print 
IF( PRESENT(ipr) ) THEN 
IF( ipr /= 0 ) THEN 
WRITE(0,'(a,i5,lp4el2.4)') 'iter, fret, gam, min(p), max(p)', & 
& iter, fret, gam, MINVAL(p), MAXVAL(p) 

END IF 
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END IF 

! Convergence test 
IF( ABS(fret-fp) <= abstol + 0.5*(reltol+EPSILON(1.0_sp)) & 

& *(ABS(fret)+ABS(fp)) ) RETURN 
fret = Func( p, xi ) 

!If at limit, don't allow gradient to push out 
IF( PRESENT(lop) ) THEN 
WHERE (p = lop .AND. xi > 0.) 
xi = 0. 
h = 0. 
END WHERE 
END IF 

IF( PRESENT(hip) ) THEN 
WHERE (p = hip .AND. xi < 0.) 
xi = 0. 
h = 0. 
END WHERE 
END IF 

IF( ALL(xi = 0.) ) RETURN 

!Set the next conjugate gradient direction 

iter = iter + 1 

gg = DOT_PRODUCT(g,g) 

!!dgg = DOT_PRODUCT( xi, xi ) ! Fletcher-Reeves 

dgg = DOT_PRODUCT( xi+g, xi ) IPolack-Ribiere 

gam = dgg/gg 

g = -xi 

h = g + gam*h 
xi = h 

END DO Iterationjoop 

!No convergence (warning only) 
WRITE(0,*) 'Frprmn: maximum iterations exceeded',itmax 

END SUBROUTINE frprmn 
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IK*******************^******************* 

Copyright (C) 1998 by Algebron LLC. 
All rights reserved. 
Unauthorized reproduction prohibited. 

Time-stamp: <98/06/29 14:07:45 ayahil> 

! ! This routine is simply a traffic cop directing to the actual minimization 
! ! functions, depending on IFLAG. There is also an option to prevent 
! ! minimization wrt to some variables by setting the appropriate gradient 
! ! components to zero. 

FUNCTION Func( & 

& z, & ! Arguments of minimization function 

& xi & ! Gradient of minimization function wrt z 

& ) RESULT( out ) 

USE Interfaces, ONLY: Cml, Ml 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq 

USE Parm, ONLY: diagv, idx, iflag, k, p, n 

IMPLICIT NONE 

! Arguments 

REAL(sp), INTENT(inout), TARGET, DIMENSION(:) :: z 

REAL(sp), OPTIONAL, INTENT(out), TARGET, DIMENSION(SIZE(z)) 

REAL(sp) :: out 

! Locals 

INTEGER :: chk 

REAL(sp), DIMENSION(p,k) :: dlambda, lambda 
REAL(sp), POINTER, DIMENSION(:) :: dsig, sig 

! Check sizes 
IF( PRESENT(xi) ) THEN 

chk = Assert_eq( p*(k+l), SIZE(z), SIZE(xi), ' Func-z' ) 
ELSE 

chk = Assert_eq( p*(k+1 ), SIZE(z), ' Func-z' ) 
END IF 

! Initialization 

sig => z(:p) 

IF( PRESENT(xi) ) THEN 

dsig => xi(:p) 
END IF 

lambda = RESHAPE(z(p+l:),(/p,k/)) 

! Select minimization function 
SELECT CASE( iflag ) 

! Standard maximum likelihood 

CASE( 1 ) 



[func.fJO] 



IF( PRESENT(xi) ) THEN 

out = Ml( lambda, sig, dlambda=dlambda, dsig=dsig ) 

xi(p+l:) = RESHAPE(dlambda,(/p*k/)) 
ELSE 

out = Ml( lambda, sig ) 
END IF 

! Maximum likelihood costrained to maintaining 
! the diagonal of the covariance matrix 
! constant 

CASE( 2 ) 

sig = SQRT( diagv/(1.0_sp + SUM( lambda**2, DIM=2 )) ) 
IF( PRESENT(xi) ) THEN 
dsig = 0.0_sp 

out = Cml( lambda, sig, dlambda=dlambda ) 
xi(p+l:) = RESHAPE(dlambda,(/p*k/)) 
ELSE 

out = Cml( lambda, sig ) 

END IF 
CASE DEFAULT 

STOP Tunc: illegal iflag' 
END SELECT 

! Disallow gradients for variables marked to 
! be constant 

IF( PRESENT(xi) .AND. ALLOCATED(idx) ) THEN 

xi(idx) = 0.0_sp 
END IF 

END FUNCTION Func 
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FUNCTION gammln_s(xx) 

USE nrtype; USE nrutil, ONLY : arth,assert 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: xx 

REAL(SP) :: gammln_s 

REAL(DP) :: tmp,x 

REAL(DP) :: stp = 2.50662827463 10005_dp 

REAL(DP), DIMENSION^) :: coef = (/76. 180091 72947 146_dp,& 
-86.50532032941677_dp,24.01409824083091_dp,& 
- 1 .23 1 73 95 72450 1 55_dp,0. 1 208650973 866 1 79e-2_dp,& 
-0.5395239384953e-5_dp/) 

call assert(xx > 0.0, 'gammln_s arg') 

x=xx 

tmp=x+5.5_dp 

tmp=(x+0.5_dp)*log(tmp)-tmp 
gammln_s=tmp+log(stp*(1.000000000190015_dp+& 

sum(coef(:)/arth(x+l .0_dp, 1 .0_dp,size(coef))))/x) 
END FUNCTION gammln_s 



FUNCTION gammln_v(xx) 
USE nrtype; USE nrutil, ONLY: assert 
IMPLICIT NONE 
INTEGER(I4B) :: i 

REAL(SP), DIMENSIONC), INTENT(IN) :: xx 

REAL(SP), DIMENSION(size(xx)) :: gammln_v 

REAL (DP), DIMENSION(size(xx)) :: ser,tmp,x,y 

REAL (DP) :: stp = 2.50662827463 10005_dp 

REAL (DP), DIMENSION^) :: coef = (/76. 180091 72947 146_dp,& 
-86.5053203294 1 677_dp,24.0 140982408309 1 _dp,& 
-1.231739572450155_dp,0.1208650973866179e-2_dp,& 
-0.5395239384953e-5_dp/) 

if (size(xx) = 0) RETURN 

call assert(all(xx > 0.0), 'gammln_v arg') 

x=xx 

tmp=x+5.5_dp 

tmp=(x+0.5_dp)*log(tmp)-tmp 
ser=l . 000000000 1 900 1 5_dp 
y=x 

do i=l,size(coef) 

y=y+1.0_dp 
ser=ser+coef(i)/y 

end do 

gammln_v=tmp+log(stp*ser/x) 
END FUNCTION gammln_v 
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FUNCTION gammq_s(a,x) 

USE nrtype; USE nrutil, ONLY : assert 

USE nr, ONLY : gcf,gser 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: a,x 

REAL(SP) :: gammq_s 

call assert( x >= 0.0, a > 0.0, 'gammq_s args') 

if(x<a+1.0_sp)then 

gammq_s=l .0_sp-gser(a,x) 

else 

gammq_s=gcf(a,x) 

end if 

END FUNCTION gammq_s 



FUNCTION gammq_v(a,x) 

USE nrtype; USE nrutil, ONLY : assert,assert_eq 

USE nr, ONLY : gcf.gser 

IMPLICIT NONE 

REAL(SP), DIMENSIONO), INTENT(IN) :: a,x 

REAL(SP), DIMENSION(size(a)) :: gammq_v 

LOGICAL(LGT), DIMENSION(size(x)) :: mask 

INTEGER(I4B) :: ndum 

ndum=assert_eq(size(a),size(x),'gammq_v') 

call assert( all(x >= 0.0), all(a > 0.0), 'gammq_v args') 

mask = (x<a+l .0_sp) 

gammq_v=merge(l .0_sp-gser(a,merge(x,0.0_sp,mask)), & 

gcf(a,merge(x,0 . O sp, .not. mask)),mask) 
END FUNCTION gammq_v 
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# 

SUBROUTINE gasdev_s(harvest) 
USE nrtype 
USE nr, ONLY : rani 
IMPLICIT NONE 

REAL(SP), INTENT(OUT) ;: harvest 

REAL(SP) ::rsq,vl,v2 

REAL(SP), SAVE :: g 

LOGICAL, SAVE :: gaus_stored= false. 

if (gaus_stored) then 

harvest=g 

gaus_stored=.false. 

else 

do 

call ranl(vl) 

call ran l(v2) 

vl=2.0_sp*vl-1.0_sp 

v2=2.0_sp*v2-1.0_sp 

rsq=v 1 * * 2+ v2 * * 2 

if (rsq > 0.0 .and. rsq < 1.0) exit 

end do 

rsq=sqrt(-2 . 0_sp* log(rsq)/rsq) 

harvest=vl*rsq 

g=v2*rsq 

gaus_stored=.true. 

end if 

END SUBROUTINE gasdev_s 

SUBROUTINE gasdev_v(harvest) 

USE nrtype; USE nrutil, ONLY : array_copy 

USE nr, ONLY : rani 

IMPLICIT NONE 

REAL(SP), DIMENSIONO), INTENT(OUT) :: harvest 

REAL(SP), DIMENSION(size(harvest)) :: rsq,vl,v2 

REAL(SP), ALLOCATABLE, DIMENSION(:) 3 SAVE :: g 

INTEGER(I4B) :; n,ng ? nn,m 

INTEGER(I4B) 5 SAVE :: last_allocated=0 

LOGICAL, SAVE :: gaus_stored=. false. 

LOGICAL, DIMENSION(size(harvest)) :: mask 

n=size(harvest) 

if (n /= last_allocated) then 

if (last_allocated /= 0) deallocate(g) 

allocate(g(n)) 

last_allocated=n 

gaus_stored= . fal se . 

end if 

if (gaus_stored) then 
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p 




harvest=g 
gaus_stored=.false. 



else 



ng=l 
do 



if (ng > n) exit 

call ranl(vl(ng:n)) 

call rani (v2(ng:n)) 

vl(ng:n)=2.0_sp*vl(ng:n)-1.0_sp 

v2(ng:n)=2.0_sp*v2(ng:n)-1.0_sp 

rsq(ng:n)=vl (ng:n)* *2+v2(ng:n)* *2 

mask(ng:n)=(rsq(ng:n)>0.0 .and. rsq(ng:n)<1.0) 

call array_copy(pack(vl(ng:n),mask(ng:n)),vl(ng:),iin,m) 

v2(ng:ng+nn- 1 )=pack(v2(ng :n) ? mask(ng:n)) 

rsq(ng : ng+nn- 1 )=pack(rsq(ng : n),mask(ng :n)) 

ng=ng+nn 

end do 

rsq=sqrt(-2.0_sp*log(rsq)/rsq) 

harvest=vl*rsq 

g=v2*rsq 

gaus_stored=.true. 

end if 

END SUBROUTINE gasdev_v 
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FUNCTION gcf_s(a,x,gln) 

USE nrtype; USE nrutil, ONLY : nrerror 

USE nr, ONLY : gammln 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: a,x 

REAL(SP), OPTIONAL, INTENT(OUT) :: gin 

REAL(SP) :: gcf s 

INTEGER(I4B), PARAMETER :: ITMAX=100 

REAL(SP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS 

INTEGER(I4B) :: i 

REAL(SP) :: an,b,c,d,del,h 

if(x = 0.0) then 

gcf_s=1.0 

RETURN 

end if 

b=x+1.0_sp-a 
c=1.0_sp/FPMIN 
d=1.0_sp/b 
h=d 

doi=l,ITMAX 

an=-i*(i-a) 

b=b+2.0_sp 

d=an*d+b 

if (abs(d) < FPMIN) d=FPMIN 
c=b+an/c 

if (abs(c) < FPMIN) c=FPMIN 

d=1.0_sp/d 

del=d*c 

h=h*del 

if (abs(del-1.0_sp) <= EPS) exit 

end do 

if (i > ITMAX) call nrerror('a too large, ITMAX too small in gcf_s') 
if (present(gln)) then 

gln=gammln(a) 

gcf_s=exp(-x+a*log(x)-gln)*h 

else 

gcf_s=exp(-x+a*log(x)-gammln(a))*h 

end if 

END FUNCTION gcf_s 



FUNCTION gcf_v(a,x,gln) 

USE nrtype; USE nrutil, ONLY : assert_eq,nrerror 

USE nr, ONLY : gammln 

IMPLICIT NONE 

REAL(SP), DIMENSION0), INTENT(IN) :: a,x 
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REAL(SP), DIMENSIONO), OPTIONAL, INTENT(OUT) :: gin 

REAL(SP), DIMENSION(size(a)) :: gcf_v 

INTEGER(I4B), PARAMETER :: ITMAX=100 

REAL(SP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS 

INTEGER(I4B) :: i 

REAL(SP), DIMENSION(size(a)) :: an,b,c,d,del,h 
LOGIC AL(LGT), DIMENSION(size(a)) :: converged,zero 
i=assert_eq(size(a),size(x) 5 f gcf_v') 
zero=(x = 0.0) 
where (zero) 

gcf_v=1.0 
elsewhere 

b=x+1.0_sp-a 

c=1.0_sp/FPMIN 

d=1.0jsp/b 

h=d 
end where 
converged=zero 
do i=l, ITMAX 

where (.not. converged) 
an=-i*(i-a) 
b=b+2.0_sp 
d=an*d+b 

d=merge(FPMIN,d, abs(d)<FPMIN ) 
c=b+an/c 

c=merge(FPMIN,c 5 abs(c)<FPMIN ) 

d=1.0_sp/d 

del=d*c 

h-h*del 

converged = (abs(del-1.0_sp)<=EPS) 
end where 

if (all(converged)) exit 

end do 

if (i > ITMAX) call nrerror( f a too large, ITMAX too small in gcf_V) 
if (present(gln)) then 

if (size(gln) < size(a)) call & 

nrerror('gser: Not enough space for gin') 

gln=gammln(a) 

where (.not. zero) gcf_v=exp(-x+a*log(x)-gln)*h 

else 

where (.not. zero) gcf_v=exp(-x+a*log(x)-gammln(a))*h 

end if 

END FUNCTION gcfv 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 20:22:42 ayahil> 

! ! ! Generate a random p x p covariance matrix 

SUBROUTINE Gen_covar( & 

& c, & ! Output covariance matrix 

& p & ! Dimension of covariance matrix 

&) 

USE Nr, ONLY: Rani 
USENrtype 

USE Nrutil, ONLY: Assert_eq, Outerprod, Unitjnatrix 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: p 
REAL(sp), INTENT(out), DIMENSION(p,p) :: c 

! Locals 

INTEGER :: chk, i 
REAL(sp), DIMENSIONS) :: e 
REAL(sp), DIMENSION(p,p) :: proj, r 
! Check sizes 

chk = Assert_eq( p, SIZE(c,l), SIZE(c,2), ' Covar-p' ) 
! Generate random eigenvalues 

CALL Ranl( e ) 

! Generate a random orthogonal transformation 
CALLRanl(r(:,l)) 
r(:,l) = 2.0_sp*r(:>l)- 1.0_sp 

r(:,l) = r(:,l)/SQRT( SUM( r(:,l)**2 ) + TINY(1.0_sp) ) 
CALL Unit_matrix( proj ) 
DOi = 2,p 

proj = proj - Outerprod( r(:,i-l), r(:,i-l) ) 

CALL Rani (r(:,i)) 

r(:,i) = MATMUL( proj, 2.0_sp*r(:,i) - 1.0_sp ) 
r(:,i) = r(:,i)/SQRT( SUM( r(:,i)**2 ) + TINY(1.0_sp)) 
END DO 

! Rotate the eigenvalues 

DO i= l,p 

c(:,i) = e(i)*r(:,i) 
END DO 

c = MATMUL( c, TRANSPOSE( r ) ) 
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END SUBROUTINE Gen_covar 
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********************************* ******** 

/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

I* if**************************************** +1 

/* Time-stamp: <98/06/13 16:46:06 ayahil> */ 

/* 

Generate a random covariance matrix C(P,P). 
*/ 

#ifhdef GEN_CO VAR_H 
#define GEN_COVAR_H 

void gen_covar( 

double* c, /* Covariance matrix. Output array(p,p) */ 

int* p /* # of variables. Input */ 

); 

#endif 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 20:23:21 ayahil> 

! ! ! Generate multivariate normal deviates with covariance matrix c. 



SUBROUTINE Gen_dev( & 

& c, & ! Covariance matrix 

& n, & ! # of deviates 

& p, & ! # of variables 

& x & ! Array of deviates 

& ) 

USE Nr, ONLY: Gasdev, Tqli, Tred2 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: n, p 
REAL(sp), INTENT(in), DIMENSION(p,p) :: c 
REAL(sp), INTENT(out), DIMENSION(n,p) :: x 

! Locals 

INTEGER ::chk,j 

REAL(sp), DIMENSION^) :: d, e 

REAL(sp), DIMENSION(p,p) :: a 

! Check sizes 
chk = Assert_eq( n, SIZE(x,l), 1 Gen_dev-n' ) 
chk = Assert_eq( p, SIZE(c,l), SIZE(c,2), SIZE(x,2), ' Gen_dev-p' ) 

! Eigenvalues/vectors of the covariance matrix 

a = c 

CALL Tred2( a, d, e ) 
CALL Tqli( d, e, a ) 

! Random Gaussian deviates in eigenvector basis 

DOj = l,p 
CALL Gasdev( x(:,j) ) 

x(:j) = SQRT(d(j))*x(:J) 
END DO 

! Rotate to given basis 
x = MATMUL( x, TRANSPOSE(a) ) 



END SUBROUTINE Gen_dev 
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/* ***************************************** 

/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

j* ***************************************** *y 

/* Time-stamp: <98/06/13 16:42:15 ayahil> */ 

/* 

Generate N multivariate normal deviates with a covariance matrix C(P,P). 
*/ 

#ifhdefGEN_DEV_H 
#define GEN_DEV_H 

void gen_dev_( 

double* c, /* Covariance matrix. Input array(p,p) */ 
int* n 5 /* # of deviates. Input */ 

int* p ? /* # of variables. Input */ 

double* x /* Random deviates generated. Output 

array(n,p) */ 

); 

#endif 



[gen_dev.h] 



***************************************** 



! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 21:13:26 ayahil> 

! ! ! Goodness-of-fit measure 

FUNCTION Get_gof( & 



& chi2, & ! Chi A 2 at each sampling point 

& gof_ev, & ! Expectation value of GOF measure 

& gofstd, & ! Standard deviation of GOF measure 

& prob, & ! Probabilities of chi A 2 array 

& r, & ! Unbiased sampling matrix 

& v, & ! Covariance matrix 

& w & ! Weights 



& ) RESULT( out ) 

USE Nr, ONLY: Gammq 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq 
USE Parm, ONLY: n, p, sm 
USE Utils, ONLY: Spd 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: w 
REAL(sp), INTENT(in), DIMENSION(:,:) :: r, v 
REAL(sp), INTENT(out) :: gof_ev, gof_std 
REAL(sp), INTENT(out), DIMENSION(n) :: chi2, prob 
REAL(sp) :: out 

! Locals 
INTEGER :: chk, i, m 

INTEGER, POINTER, DIMENSION^ :: idx 
REAL(sp), ALLOC ATABLE, DIMENSION(:) :: x 
! Check sizes 

chk = Assert_eq( (/ n, SIZE(chi2), SIZE( prob), SIZE(r,l), SIZE(w) /), & 
& ' Gof-n' ) 

chk = Assert_eq( p, SIZE(r,2), SIZE(v,l), SIZE(v,2), ' Gof-p" ) 
! Build up 2*chi A 2 a sampling point at a time 

gof_ev = 0.0_sp 
gofstd = 0.0_sp 
out = O.Osp 
Data loop: DO i= l,n 

idx => sm(i)%idx 

m = SIZE(idx) 
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IF( m > 0 ) THEN 

ALLOCATE( x(m) ) 

CALL Spd( v(idx,idx), b=r(i,idx), x=x ) 

chi2(i) = DOT_PRODUCT( r(i,idx), x ) 

out = out + w(i)*(chi2(i) - m)**2 

DEALLOCATE( x ) 

gof_ev = gof_ev + 2*m*w(i) 

gof_std = gof_std + 8*m*(m + 6)*w(i)**2 

prob(i) = Gammq( 0.5_sp*m, 0.5_sp*chi2(i) ) 
ELSE 

chi2(i) = 0.0_sp 

prob(i) = 0.0_sp 
END IF 
END DO Datajoop 
gof_std = SQRT( gof_std ) 

END FUNCTION Get_gof 
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FUNCTION gser_s(a,x,gln) 

USE nrtype; USE nrutil, ONLY : nrerror 

USE nr, ONLY : gammln 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: a,x 

REAL(SP), OPTIONAL, INTENT(OUT) :: gin 

REAL(SP) :: gser_s 

INTEGER(I4B), PARAMETER :: ITMAX=100 
REAL(SP), PARAMETER :: EPS=epsilon(x) 
INTEGER(I4B) :: n 
REAL(SP) : : ap,del,summ 
if (x = 0.0) then 

gser_s=0.0 

RETURN 

end if 
ap=a 

summ=1.0_sp/a 

del=summ 

don=l,ITMAX 

ap=ap+1.0_sp 

del=del*x/ap 

summ=summ+del 

if (abs(del) < abs(summ)*EPS) exit 

end do 

if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_s') 
if (present(gln)) then 
gln=gammln(a) 

gser_s=summ * exp(-x+a* log(x)-gln) 

else 

gser_s=summ * exp(-x+a* log(x)-gammln(a)) 

end if 

END FUNCTION gser_s 



FUNCTION gser_v(a,x,gln) 

USE nrtype; USE nrutil, ONLY : assert_eq,nrerror 

USE nr, ONLY : gammln 

IMPLICIT NONE 

REAL(SP), DIMENSION0), INTENT(IN) :: a,x 

REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gin 

REAL(SP), DIMENSION(size(a)) :: gser_v 

INTEGER(I4B), PARAMETER :: ITMAX=100 

REAL(SP), PARAMETER :: EPS=epsilon(x) 

INTEGER(I4B) :: n 

REAL(SP), DIMENSION(size(a)) :: ap,del,summ 
LOGIC AL(LGT), DIMENSION(size(a)) :: converged,zero 
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n=assert_eq(size(a) ? size(x), , gser_v') 

zero=(x = 0.0) 

where (zero) gser_v=0.0 

ap=a 

summ=1.0_sp/a 
del=summ 
converged=zero 
don=l,ITMAX 

where (.not. converged) 

ap=ap+1.0_sp 

del=del*x/ap 

summ=summ+del 

converged = (abs(del) < abs(summ)*EPS) 
end where 

if (all(converged)) exit 

end do 

if (n > ITMAX) call nrerror('a too large, ITMAX too small in gser_V) 
if (present(gln)) then 

if (size(gln) < size(a)) call & 

nrerror( ! gser: Not enough space for gin') 

gln=gammln(a) 

where (.not. zero) gser_v=summ*exp(-x+a*log(x)-gln) 

else 

where (.not. zero) gser_v=stimm*exp(-x+a*log(x)-gammln(a)) 

end if 

END FUNCTION gser_v 
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SUBROUTINE indexx_sp(arr, index) 

USE nrtype; USE nrutil, ONLY : arth,assert_eq,nrerror,swap 
IMPLICIT NONE 

REAL(SP), DIMENSIONS, INTENT(IN) :: arr 
INTEGER(I4B), DIMENSIONS, INTENT(OUT) :: index 
INTEGER(I4B) 5 PARAMETER :: NN=15, NSTACK=50 
REAL(SP) :: a 

INTEGER(I4B) :: n,k,i J, indextj stacker 

INTEGER(I4B), DIMENSION(NSTACK) :: istack 

n=assert_eq(size(index),size(air), , indexx_sp') 

index=arth(l,l,n) 

jstack=0 

1=1 

r=n 

do 

if(r-KNN)then 
doj=l+l,r 

indext=index(j) 
a=arr(indext) 

doi=j-l,l,-l 

if (arr(index(i)) <= a) exit 
index(i+l)=index(i) 

end do 

index(i+l)=indext 

end do 

ifGstack = 0) RETURN 
r=istack(j stack) 
l=istack(jstack-l) 
jstack=jstack-2 

else 

k-(l+r)/2 

call swap(index(k),index(l+l)) 
call icomp_xchg(index(l),index(r)) 
call icomp_xchg(index(l+ 1 ),index(r)) 
call icomp_xchg(index(l),index(l+l)) 
i=l+l 
j=r 

indext=index(l+l) 

a=arr(indext) 

do 

do 

i=i+l 

if (arr(index(i)) >= a) exit 

end do 
do 

j=j-l 
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if (arr(index(j)) <= a) exit 

end do 

if (j < i) exit 

call swap(index(i) 5 index(j)) 

end do 

index(l+ 1 )=index(j ) 

indexQ^indext 

jstack=jstack+2 

if Gstack > NSTACK) call nrerror('indexx: NSTACK too small') 
if (r-i+1 >=j-l) then 

istack(jstack)=r 

istack(j stack- l)=i 

r=j-l 

else 

istack(jstack)=j-l 
istack(j stack- 1 )=1 
l=i 

end if 

end if 

end do 
CONTAINS 

SUBROUTINE icomp_xchg(ij) 
INTEGER(I4B), INTENT(INOUT) :: i,j 
INTEGER(I4B) :: swp 
if (arrG) < arr(i)) then 
swp=i 

i=j 

j=swp 

end if 

END SUBROUTINE icomp_xchg 
END SUBROUTINE indexx_sp 

SUBROUTINE indexx_i4b(iarr,index) 

USE nrtype; USE nrutil, ONLY : arth,assert_eq,nrerror,swap 

IMPLICIT NONE 

INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr 
INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index 
INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 
INTEGER(I4B) :: a 

INTEGER(I4B) :: n,k,i,j,indextjstack,l,r 

INTEGER(I4B), DIMENSION (N STACK) :: istack 

n=assert_eq(size(index),size(iarr),'indexx_sp') 

index=arth(l,l,n) 

jstack=0 

1=1 
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r=n 
do 

if(r-KNN) then 
doj=l+l,r 

indext=index(j) 
a=iarr(indext) 

do i=j-l,l,-l 

if (iarr(index(i)) <= a) exit 
index(i+ 1 )=index(i) 

end do 

index(i-f 1 )=indext 

end do 

ifGstack = 0) RETURN 
r=istack(j stack) 
l=istack(j stack- 1) 
jstack=jstack-2 

else 

k=(l+r)/2 

call swap(index(k),index(l+l)) 
call icomp_xchg(index(l),index(r)) 
call icomp_xchg(index(l+ 1 ),index(r)) 
call icomp_xchg(index(l),index(l+ 1 )) 
i=l+l 

indext=index(l+l) 

a=iarr(indext) 

do 

do 

i=i+l 

if (iarr(index(i)) >= a) exit 

end do 
do 

M-i 

if (iarr(index(j)) <= a) exit 

end do 

if (j < i) exit 

call swap(index(i) 5 index(j)) 

end do 

index(l+ 1 )=index(j) 

index(j)=indext 

jstack=jstack+2 

if (jstack > NSTACK) call nrerror('indexx: NSTACK too small 1 ) 
if (r-i+1 >=j-l) then 

istack(jstack)=r 

istack(j stack- l)=i 

r=j-l 
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else 

istack(jstack)=j-l 
istack(j stack- 1)=1 
l=i 

end if 

end if 

end do 
CONTAINS 

SUBROUTINE icomp_xchg(ij) 
INTEGER(I4B), INTENT(INOUT) :: ij 
INTEGER(I4B) :: swp 
if (iarr(j) < iarr(i)) then 

swp=i 

i=j 

j=swp 

end if 

END SUBROUTINE icomp_xchg 
END SUBROUTINE indexx_i4b 



[indexx.fPO] 



! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited, 
t**************************^************* 

! Time-stamp: <98/04/04 15:26:58 ayahil> 

!!! IDL-like functions INDGEN & FINDGEN returning the integers from 1 to n. 
!!! Note the important difference: the series begin with 1, not 0, to conform 
! ! ! to standard FORTRAN usage. 

FUNCTION Indgen( n ) RESULT( out ) 

IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: n 
INTEGER, DIMENSIONS) :: out 

! Locals 

INTEGER ::i 

out = (/(i, i=l,n)/) 

END FUNCTION Indgen 

FUNCTION Findgen( n ) RESULT( out ) 

USE Nrtype 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: n 
REAL(sp), DIMENSION(n) :: out 

! Locals 

INTEGER ::i 
out = (/(i,i=l,n)/> 
END FUNCTION Findgen 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 21:43:38 ayahil> 

MODULE Interfaces 

INTERFACE 

SUBROUTINE Algebron( abstol, add_iter, chi2, gof, gof_ev, gof_std, n 

& nsig, p_t, pm, prob, r_t, reltol, signif, stepmx, v, w_t, z ) 
USE Nrtype 

INTEGER, INTENT(in) :: add_iter, prn, stepmx 
INTEGER, INTENT(in), TARGET : : n_t, p_t 
REAL(sp), INTENT(in) :: abstol, nsig, reltol, signif 
REAL(sp), INTENT(in), TARGET, DIMENSION(n_t) :: w_t 
REAL(sp), INTENT(in), TARGET, DIMENSION(n_t,p_t) :: r_t 
REAL(sp), INTENT(inout), DIMENSION(p_t*(p_t+l)) :: z 
REAL(sp), INTENT(out) :: gof, gof_ev, gof_std 
REAL(sp), INTENT(out), DIMENSION(n_t) :: chi2, prob 
REAL(sp), INTENT(out), DIMENSION(p_t,p_t) :: v 
END SUBROUTINE Algebron 
END INTERFACE 

INTERFACE 

FUNCTION Cml( lambda, sig, dlambda ) RESULT( out ) 
USE Nrtype 
USE Parm, ONLY: k, p 

REAL(sp), INTENT(in), DIMENSION(:) :: sig 
REAL(sp), INTENT(in), DIMENSION(:,:) :: lambda 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(p,k) :: dlambda 
REAL(sp) :: out 
END FUNCTION Cml 
END INTERFACE 

INTERFACE 
FUNCTION Covar( z ) RESULT( out ) 
USE Nrtype 
USE Parm, ONLY: p 

REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), DIMENSION(p,p) :: out 
END FUNCTION Covar 
END INTERFACE 

INTERFACE 
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FUNCTION Cull( In, nsig, z ) RESULT( out ) 
USE Parm, ONLY: k, p 
USE Nrtype 

REAL(sp), INTENT(in) :: nsig 
REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), INTENT(in), DIMENSION^ :: In 
REAL(sp), DIMENSION(k*p) :: out 
END FUNCTION Cull 
END INTERFACE 

INTERFACE 
FUNCTION Func( z, xi ) RESULT( out ) 
USE Nrtype 

REAL(sp), INTENT(in), TARGET, DIMENSION(:) :: z 

REAL(sp), OPTIONAL, INTENT(inout), TARGET, DIMENSION(SIZE(z)) :: xi 
REAL(sp) :: out 
END FUNCTION Func 
END INTERFACE 

INTERFACE 
SUBROUTINE Gen_covar( c, p ) 
USE Nrtype 

INTEGER, INTENT(in) :: p 
REAL(sp), INTENT(out), DIMENSION(p,p) :: c 
END SUBROUTINE Gen_covar 
END INTERFACE 

INTERFACE 
SUBROUTINE Gen_dev( c, n, p, x ) 
USE Nrtype 

INTEGER, INTENT(in) :: n, p 
REAL(sp), INTENT(in), DIMENSION(p,p) :: c 
REAL(sp), INTENT(out), DIMENSION(n,p) :: x 
END SUBROUTINE Gen_dev 
END INTERFACE 

INTERFACE 

FUNCTION Get_gof( chi2, gof_ev, gof_std, prob, r, v, w ) RESULT( out ) 
USE Nrtype 
USE Parm, ONLY: n 

REAL(sp), INTENT(in), DIMENSION(:) :: w 
REAL(sp), INTENT(in), DIMENSION(:,:) :: r, v 
REAL(sp), INTENT(out) :: gof_ev, gof_std 
REAL(sp), INTENT(out), DIMENSION(n) :: chi2, prob 
REAL(sp) :: out 
END FUNCTION Get_gof 
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END INTERFACE 



INTERFACE 

FUNCTION Ml( lambda, sig, dlambda, dsig ) RESULT( out ) 
USE Nrtype 
USE Parm, ONLY: k, p 
REAL(sp), INTENT(in), DIMENSION(:) :: sig 
REAL(sp), INTENT(in), DIMENSION(:,:) :: lambda 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION^) :: dsig 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(p,k) :: dlambda 
REAL(sp) :: out 

END FUNCTION Ml 
END INTERFACE 

INTERFACE 
FUNCTION Next( z ) RESULT( out ) 
USE Parm, ONLY: p 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), DIMENSIONS) :: out 
END FUNCTION Next 
END INTERFACE 

INTERFACE 

SUBROUTINE Prepare( cntmn, idx, n, p, pO, prune, r, ravg, w, x ) 
USE Nrtype 

INTEGER, INTENT(in) :: cntmn, n, pO 
INTEGER, INTENT(out) :: p 
INTEGER, INTENT(out), DIMENSION(pO) :: idx 
REAL(sp), INTENT(in) :: prune 
REAL(sp), INTENT(in), DIMENSION(n) :: w 
REAL(sp), INTENT(in), DIMENSION(n,pO) :: x 
REAL(sp), INTENT(out), DIMENSION(n,pO) :: r 
REAL(sp), INTENT(out), DIMENSION(pO) :: ravg 
END SUBROUTINE Prepare 
END INTERFACE 

INTERFACE 
SUBROUTINE Sample( In, r, s, w ) 
USE Nrtype 
USE Parm, ONLY: p 

REAL(sp), INTENT(in), DIMENSION(:) :: w 
REAL(sp), INTENT(in), DIMENSION(:,:) :: r 
REAL(sp), INTENT(out), DIMENSION^) :: In, s 
END SUBROUTINE Sample 
END INTERFACE 



[interfaces.reO] 



END MODULE Interfaces 
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! Copyright (C) 1997 by Amos Yahil. 

! All Rights Reserved. 

! Based on (C) Numerical Recipes software. 

! Time-stamp: <98/06/07 14:46:19 ayahil> 
MODULE fldim_mod 
USE nrtype 

REAL(SP), DIMENSION(:), POINTER :: pcom,xicom 
CONTAINS 

!BL 

FUNCTION fldim(x,df) 
IMPLICIT NONE 
REAL(SP), INTENT(IN) :: x 
REAL(SP), OPTIONAL, INTENT(OUT) :: df 
REAL(SP) :: fldim 
INTERFACE 
FUNCTION fiinc(x,g) 
USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: x 
REAL(SP), DIMENSION(SIZE(x)), OPTIONAL, INTENT(OUT) 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 

REAL(SP), DIMENSION(SIZE(pcom)) :: g 
IF(PRESENT(df)) THEN 

fl dim=func(pcom+x*xicorn,g) 

df=DOT_PRODUCT(g,xicom) 
ELSE 

fldim=func(pcom+x*xicom) 
END IF 
END FUNCTION fldim 
END MODULE fldim_mod 

SUBROUTINE linmin(p,xi,fret,dx,lop,hip) 

USE nrtype; USE nrutil, ONLY : assert_eq,imaxloc,iminloc,nrerror 

USE mynr, ONLY : mnbrak,brent 

USE fldim_mod 

IMPLICIT NONE 

REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONS, TARGET, INTENT(INOUT) :: p,xi 
REAL(SP), OPTIONAL :: dx 

REAL(SP), DIMENSIONS, OPTIONAL, INTENT(in) :: hip,lop 
INTEGER(I4B) :: in,ix,np 
REAL(SP) : : ax,bx,df,fa,fb,fx,xmin,xx 
REAL(SP), DIMENSION(SIZE(p)) :: hix,lox 
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! Check dimensions 
np=assert_eq(SIZE(p),SIZE(xi),'linmiri) 

!Set limits 
lox = -HUGE(1.0_sp) 
hix = HUGE(1.0_sp) 
IF (PRESENT(lop)) THEN 
np=assert_eq(np,SIZE(lop),'linmin: lop size') 
IF (MINVAL(p-lop) < 0.0) THEN 
WRITE(0,*) p 

CALL nrerror('linmin: p < lop') 
END IF 

WHERE (lop > -HUGE(1.0_sp) .AND. xi < 0.0) 

hix=(lop-p)/xi 
END WHERE 

WHERE (lop > -HUGE(1.0_sp) .AND. xi > 0.0) 

lox=(lop-p)/xi 
END WHERE 
END IF 

IF (PRESENT(hip)) THEN 
np=assert_eq(np,SIZE(hip),'linmin: hip size') 
IF (MAXVAL(p-hip) > 0.0) THEN 
WRITE(0,*) p 

CALL nrerror('linmin: p > hip') 
END IF 

WHERE (hip < HUGE(1.0_sp) .AND. xi > 0.0) 

hix=(hip-p)/xi 
END WHERE 

WHERE (hip > HUGE(1.0_sp) .AND. xi < 0.0) 

lox=(hip-p)/xi 
END WHERE 
END IF 

[Variables passed to fldim 

pcom => p 
xicom => xi 

! Prepare limits for mnbrak 

in=iminloc(hix) 
ix=imaxloc(lox) 
ax=0.0 

IF (PRESENT(dx)) THEN 

xx=MIN(dx,0.5_sp*hix(in)) 
ELSE 

xx=MIN(l .0_sp,0.5*hix(in)) 
END IF 
fa=Fldim(ax) 

DO WHILE (Fldim( xx ) > fa) 
xx=0.5*xx 
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END DO 

! Bracket minimization limits 
CALL mnbrak(ax,xx,bx,fa,fx,fb,fl dim,lox=lox(ix),hix=hix(in)) 
! Check for minimum at boundaries. The 
! parameter which forces the boundary should 
! be set exactly to avoid roundoff error. 
IF (bx = lox(ix)) THEN 

fret=fldim(bx,df) 
IF (df> 0.0) THEN 

xi=bx*xi 

p=p+xi 

IF (xi(ix) < 0.0) THEN 

p(ix)=lop(ix) 
ELSE 

p(ix)=hip(ix) 
END IF 
RETURN 
END IF 
END IF 

IF (bx = hix(in)) THEN 
fret=fldim(bx,df) 
IF (df< 0.0) THEN 

xi=bx*xi 

p=p+xi 

IF (xi(in) < 0.0) THEN 

p(in)=lop(in) 
ELSE 

p(in)=bip(in) 
END IF 
RETURN 
END IF 
END IF 

! Minimize within interval 
fret=brent(ax,xx,bx,fldim,SQRT(EPSILON(1.0_sp)),xmin) 
! Update the parameters 

xi=xmin*xi 
p=p+xi 

END SUBROUTINE linmin 
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/*******************************************************************/ 

/* */ 

/* Copyright (C) 1998 Rainbow Technologies, Inc. */ 

/* All Rights Reserved */ 

/* */ 

/* This Module contains Proprietary Information of Rainbow */ 

/* Technologies, Inc., and should be treated as Confidential. */ 

/***« ********************************* ******************************/ 

#ifndef_LSERV_H_ 
#define_LSERV_H_ 

/*pj** ****************************************************** ******** 

* FILENAME : Iserv.h 
* 

♦DESCRIPTION: 

* Contains public function prototypes, macros and defines 

* needed for licensing an app using SentinelLM library. 
* 

* USAGE : 

* This file should be included by all users of SentinelLM 

* client library. 

* NOTES : 
* 

*H*/ 

#ifdef cplusplus 

extern "C" { 
#endif 

#include <stdio.h> /* For definition of FILE* */ 
/* 

# Developer should compile with _VWIN31X_ for 16 bit Windows (Windows 3.1x). 

# Developer can compile with LSNOPROTO to force no prototyping. 
*/ 

#if defined (_V WIN3 1 X J 
/* MS Windows 3.1x application */ 

# define VMSWINAPI _far _pascal 

# define LSFAR _far 

# define VDLL32 

#elif defined(_VWIN95J || defined(_VWTNNTJ 
/* 32-bit MS Windows application */ 

/* This section is for internal use. Do not define _VWIN95_ or _VWTNNT_ */ 

# define VMSWINAPI 



(Iserv.hl 



# define LSFAR 

# define VDLL32 _declspec(dllexport) 
#else 

# define VMSWINAPI 

# define LSFAR 

# define VDLL32 
#endif /* MS Windows */ 



/* */ 

/* To inactivate licensing completely, use the following macro which 
/* will make all SentinelLM functions void: */ 
/* */ 

/* 

#defineNO_LICENSE 
*/ 

/* */ 

/* LSAPI constants */ 

/* */ 

#define LS_DEFAULT_UNITS (unsigned long)OxFFFFFFFF 
#define LS_ANY ((unsigned char LSFAR *)NULL) 

#define LS_USE_LAST (unsigned long)0x0800FFFF 

/* */ 

/* Standalone mode constants */ 
/* */ 

#define VLS_STAND ALONE "no-net" 

/* */ 

/* Trace level */ 

/* */ 

#define VLS_NO_TRACE 1 /* This is the default value */ 

#defme VLS_TRACE_KEYS 2 
#define VLS_TRACE_FUNCTIONS 4 
#define VLS_TRACE_ERRORS 8 
#defme VLS_TRACE_ALL 16 

/* */ 

/* Error handling */ 

/* */ 
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#define VLS_ON 1 /* This is the default value */ 

#define VLS_OFF 0 

/* */ 

/* Error handling */ 

/* */ 

#defme VL S_EH_SET_ALL 0 

/* */ 

/* True/False */ 

/* */ 

#define VLS_TRUE 0 
#define VLS_FALSE 1 

/* . — :._*/ 

/* Sharing criteria */ 

/* */ 

#define VLS_NO_SHARING 0 
#define VLS_USER_NAME_ID 1 
#define VL SCLIENTHO STN AME_ID 2 
#define VLS_X_DISPLAY_NAME_ID 3 
#defme VLS_VENDOR_SHARED_ID 4 
#define VLS_NO_SHARING_STRING "0" 
#define VLS_USER_NAME_ID_STRING " 1 " 
#define VLS_CLIENT_HOST_NAME_ID_STRING "2" 
#define VLS_X_DISPLAY_NAME_ID_STRING "3" 
#define VL S_VENDOR_SHARED_ID_STRING "4" 

/* */ 

/* Holding criteria */ 

/* */ 

#define VLSHOLDNONE 0 
#define VLS_HOLD_VENDOR 1 
#define VLS_HOLD_CODE 2 
#define VLS HOLD NONE STRING "0" 
#define VLS_HOLD_VENDOR_STRING " 1 " 
#define VLS_HOLD_CODE_STRING "2" 

/* */ 

/* Client-server lock mode */ 
/* */ 

#define VLS_NODE_LOCKED 0 
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#define VLS FLOATING 1 
#defme VLS DEMO MODE 2 
#define VLSCLIENTNODELOCKED 3 

/* */ 

/* Locking criteria */ 

/* */ 

/* Test whether a particular locking criterion is being used. */ 
#defme VLS_LOCK_TO_ID_PROM(V) (( (V) » 0 ) & 0x1 ) 
#define VLS_LOCK_TO_IP_ADDR(V) (( (V) » 1 ) & 0x1 ) 
#define VLS_LOCK_TO_DISK_ID(V) (( (V) » 2 ) & 0x1) 
#define VLS_LOCK_TO_HOSTNAME(V) (( (V) » 3 ) & 0x1) 
#defme VLS_LOCK_TO_ETHERNET(V) (( (V) » 4 ) & 0x1) 
#define VLS_LOCK_TO_NW_IPX(V) (( (V) » 5 ) & 0x1) 
#define VLS_LOCK_TO_NW_SERIAL(V) (( (V) » 6 ) & 0x1) 
#define VLS_LOCK_TO_PORTABLE_SERV(V) (( (V) » 7 ) & 0x1) 
#define VLS_LOCK_TO_CUSTOM(V) (( (V) » 8 ) & 0x1 ) 

/* To set a particular locking criterion. */ 
#define VLS_LOCK_ID_PROM 0x1 
#define VLS_LOCK_IP_ADDR 0x2 
#define VLS_LOCK_DISK_ID 0x4 
#define VLS_LOCK_HOSTNAME 0x8 
#define VLS_LOCK_ETHERNET Ox 1 0 
#define VLS_LOCK_NW_IPX 0x20 
#define VLS_LOCK_NW_SERIAL 0x40 
#define VLS_LOCK_PORTABLE_SERV 0x80 
#defme VLS_LOCK_CUSTOM 0x100 
/* Highest bit currently in use : */ 

#define VLS_LOCK_HIGHEST_BIT 9 /* Starting from 1... */ 
/* Mask with all locking criteria set. */ 
#defme VLS LOCK ALL Ox IFF 



/* */ 

/* License does not have an expiration date */ 
/* */ 

#define VLS_NO_EXPIRATION -1 

/* */ 

/* This number represents infinite keys */ 
/* */ 

#define VLS_INFINITE_KEYS Oxffff 
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#defineVLS INFINITE KEYS STRING 



/* 

/* Type definitions 



*/ 



*/ 



*/ 



typedef unsigned long 
typedef unsigned long 



LS_STATUS_CODE; 
LS_HANDLE; 



#define MAX_NAME_LEN 128 
#define MAX_BUF_LEN 512 

#define VLS_DISC_NO_OPTIONS 0 
#define VLS_DISC_RET_ON_FIRST 1 
#define VLS_DISC_PRIORITIZED_LIST 2 
#define VLS_DISC_NO_USERLIST 4 

#define VLS_DISC_DEFAULT_OPTIONS VLS_DISC_NO_OPTIONS 

#define NO_RET_ON_FIRST 0 
#define RETONFIRST 1 

typedef enum { VL S_LOC AL_UPD_EN ABLE, VLS_LOCAL_UPD_DISABLE} 
VLS_LOC_UPD_STAT; 

/* */ 

/* Challenge, ChallengeResponse structs */ 
/* */ 

typedef struct { 

unsigned long ulReserved; 

unsigned long ulChallengedSecret; 

unsigned long ulChallengeSize; 

unsigned char ChallengeData[30]; 
} CHALLENGE, LS_CHALLENGE; 

typedef struct { 

unsigned long ulResponseSize; 

unsigned char ResponseData[16]; 
} CHALLENGERESPONSE; 

/* : */ 

/* Client and feature information structures */ 

/* To be used in VLSgetClientlnfo, VLSgetFeaturelnfo and VLShandlelnfo */ 

/* */ 
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#defme MAXFEALEN 64 
#define MAXLEN MAXFEALEN 
#define SITEINFOLEN 150 
#define VENINFOLEN 1 00 
#define MAXCLLOCKLEN 200 

/* Client Information structure */ 
struct client_info_struct { 

char user_name[MAXLEN]; 

unsigned long host_id; 

char group [MAXLEN] ; 

long start_time; 

long hold_time; 

long end_time; 

long key_id; 

char host_name [MAXLEN]; 

char x_display_name[MAXLEN] ; 

char shared_id_name [MAXLEN] ; 

int num_units; 

int q_wait_time; 

int isjiolding; /* VLS_TRUE/VLS_FALSE */ 

int is_sharing; /* # of clients using this key */ 

}; 

typedef struct client_info_struct VLSclientlnfo; 

/* Feature Information structure */ 

struct feature_info_struct { 

char feature_name[MAXFEALEN] ; 

char version[MAXFE ALEN] ; 

long birth_day; 

long death_day; 

int num_licenses; 

int total_resv; 

int lic_from_resv; 

int lic_from_free_pool; 

int is_node_locked; /* VLS_FLOATINGA^LS_NODE_LOCKED/... */ 

int concurrency; 

int sharing_crit; 

int locking_crit; 

int holding_crit; 

int num_subnets; 

char site_license_info[SITEINFOLEN]; 

long hold_time; 

int meter_value; 

char vendor_info[VENINFOLEN]; 

char clJock_info[MAXCLLOCKLEN]; 
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long key_life_time; 

int sharing_limit; 

int soft_num_licenses; 

int is_standalone; /* VLS_TRUE/VLS_FALSE */ 
int check_time_tamper; /* VLS_TRUE/VLS_FALSE */ 
int is_additive; /* VLS_TRUE/VLS_FALSE */ 

}; 

typedef struct feature_info_struct VLSfeaturelnfo; 

/* */ 

/* Client version information structure */ 
/* To be used in VLSgetLiblnfo */ 
/* */ 

/* VLSgetLibInfo() should return the same version string in szVersipn: */ 
#define LS_VERSION "6.0" 

#define L S PROD NAME "SentinelLM" 

#define LS_COPYRIGHT \ 

" Copyright (C) 1998 Rainbow Technologies, Inc.\n\n" 
#define LIBINFOLEN 32 

typedef struct { 

unsigned long ullnfoCode; 

char szVersion [LIBINFOLEN] 

char szProtocol [LIBINFOLEN] 

char szPlatform [LIBINFOLEN] 

char szUnusedl [LIBINFOLEN]; 

char szUnused2 [LIBINFOLEN]; 
} LS_LIB VERSION; 

/* */ 

/* install info structure holds setup information for Sentinel LM 
/* To be used in VLSinstall */ 
/* */ 



typedef struct { 
long size; 
char * regKey; 
char * reg Value; 
char * installDir; 
long timel; 
long time2; 
long reserved 1; 
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} VLSinstalllnfo; 



/* */ 

/* Macros for status codes */ 
/* prefix LS : LSAPI status codes */ 
/* prefix VLS : Our own status codes */ 
/*.„ . */ 



/* The function completed successfully */ 
#define LS_SUCCESS 0x0 

/* Handle used on call did not describe a valid licensing system context */ 
#define LS_BADHANDLE (LS_STATUS_CODE)0xC8001001 

/* Licensing system could not locate enough available licensing resources */ 

/* to satisfy the request */ 

#defme LSJNSUFFICIENTUNITS (LS_STATUS_CODE)0xC800 1 002 

/* No licensing system could be found with which to perform the function */ 
/* invoked */ 

#defme LS JLICENSES YSNOTAVAILABLE (LS_STATUS_CODE)0xC8001 003 

/* The licensing system has determined that the resources used to satisfy */ 
/* a previous request are no longer granted to the calling software */ 
#define LS_LICENSETERMINATED (LS_STATUS_CODE)0xC800 1 004 

/* The licensing system has no licensing resources that could satisfy the */ 
/* request. */ 

#define LS_NO AUTHORIZATION A VAIL ABLE (LS_STATUS_CODE)OxC8001005 

/* The licensing system has licensing resources that could satisfy the */ 

/* request, but they are not available at the time of the request */ 

#define LS_NOLICENSES AVAIL ABLE (LS_STATUS_CODE)0xC8001006 

/* Insufficient resources (such as memory) are available to complete the */ 
/* request */ 

#define LS_NORESOURCES (LS_STATUS_CODE)0xC8001007 

/* The network is unavailable */ 

#define LS_NO_NET WORK (LS_STATUS_CODE)0xC800 1008 

/* A warning occured while looking up an error messge string for the */ 

/* LSGetMessage() function */ 

#define LS_NO_MSG_TEXT (LS_STATUS_CODE)0xC8001009 

/* An unrecognized status code was passed into the LSGetMessageQ function*/ 
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#defme LSJJNKNO WN_STATUS (LS_STATUS_CODE)0xC800 1 00A 

/* An invalid index was specified in LSEnumProviders() or LSQuery License */ 
#define L S_B AD_IND EX (LS_STATUS_CODE)0xC800 1 00B 

/* No additional units are available */ 

#define LS_NO_MORE_UNITS (LS_STATUS_CODE)0xC800 1 00C 

/* The license associated with the current context has expired. This may */ 

/* be due to a time-restriction on the license */ 

#defme LS_LICENSE_EXPIRED (LS_STATUS_CODE)0xC800 1 00D 

/* Input buffer is too small, need a bigger buffer */ 

#define LS_BUFFER_TOO_SMALL (LS_STATUS_CODE)0xC8001 00E 

/* No success in achieving the target */ 

#define LS_NO_SUCCESS (LS_STATUS_CODE)0xC800 1 OOF 



/* 1 . Generic error when a license is denied by a server. 

* If reasons are known, more specific errors are given */ 
#define VLS_N0_LICENSEJ3IVEN 1 

/* 2. Application has not been given a name. */ 
#define VLS_APPJJNNAMED 2 

/* 3. Unkown host (Application is given a server name but that 

* server name doesnt seem to exist) */ 
#defme VLS_HOST_UNKNOWN 3 

/* 4. No FILE giving license server name (Application cannot figure 

* out the license server. */ 

#define VLS_NO_SERVER_FILE 4 

/* 5. On the specified machine, license server is not RUNNING. */ 
#define VLS_NO_SERVER_RUNNING 5 

/* 6. This /feature is node locked but the request for a key came 

* from a machine other than the host running the SentinelLM server. */ 
#define VLS_APP__NODE_LOCKED 6 

/* 7. LSrelease called when this copy of the application had not 

* received a valid key from the SentinelLM server. */ 
#define VLS_NO_KEY__TO_RETURN 7 

/* 8. Failed to return the key issued to this copy of the application */ 
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#define VLS_RETURN_F AILED 8 

/* 9. End of clients on calling VLSgetClientlnfo */ 
#define VLS_NO_MORE_CLIENTS 9 

/* 10. End of features on calling VLSgetFeaturelnfo */ 
#define VLS_NO_MORE_FEATURES 1 0 

/* 1 1 . General error by vendor in calling function etc. */ 
#define VLSCALLINGERROR 1 1 

/* 12. Internal error in SentinelLM */ 
#defme VLS JNTERNAL_ERROR 1 2 

/* 13. Irrecoverable Internal error in SentinelLM */ 
#define VLS_SEVERE_INTERNAL_ERROR 1 3 

/* 14. On the specified machine, license server is not responding. 

* (Probable cause - network down, wrong port number, some other 

* application on that port etc.) */ 

#define VLS_NO_SERVER_RESPONSE 1 4 

/* 15. User/machine excluded */ 

#define VLS_USER_EXCLUDED 1 5 

/* 16. Unknown shared id */ 

#define VLS_UNKNOWN_SHARED_ID 1 6 

/* 17. No servers responded to client broadcast */ 
#define VLS_NO_RESPONSE_TO_BROADCAST 17 

/* 18. No such feature recognized by server */ 
#define VLS_NO_SUCH_FEATURE 1 8 

/* 19. Failed to add license */ 

#define VLS_ADD_LIC_F AILED 1 9 

/* 20. Failed to delete license */ 

#define VLS_DELETE_LIC_F AILED 20 

/* 21. Last update was done locally */ 
#define VLS_LOCAL_UPDATE 2 1 

/* 22. Last update was done by the SentinelLM server */ 
#define VLS_REMOTE_UPDATE 22 
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/* 23. The vendor identification of requesting application does not 

* match with that of the application licensed by this system. */ 
#define VLSJVENDORIDMISMATCH 23 

/* 24. The server has licenses for the same feature,version from multiple 

* vendors, and it is not clear from the requested operation which license 

* the requestor is interested in. */ 

#define VLS_MULTIPLE_VENDORID_FOUND 24 

/* 25. An error has occured in decrypting (or decoding) a network message. 

* Probably an incompatible or unknown server, or a version mismatch. */ 
#define VLS_BAD_SERVER_MESSAGE 25 

/* 26. The server has found evidence of tampering of the system clock, 

* and it cannot service the request since the license for this feature 

* has been set to be time tamper proof. */ 
#define VLS_CLK_TAMP_FOUND 26 

/* 27. The specified operation is not permitted - authorization failed. */ 
#define VLS_NOT_ AUTHORIZED 27 

/* 28. The domain of server is different from that of client. */ 
#defineVLS INVALID DOMAIN 28 



/* 

/* Function Prototypes */ 
/* 



VDLL32 LS_STATUS_CODE VMSWINAPI LSRequest ( 
#ifndefLSNOPROTO 

unsigned char LSFAR *license_system, 

unsigned char LSFAR *publisherjiame, 

unsigned char LSFAR *product_name, 

unsigned char LSFAR *version, 

unsigned long LSFAR *units_reqd, 

unsigned char LSFAR *log_comment, 

LS_CHALLENGE LSFAR "challenge, 

LS_HANDLE LSFAR *lshandle 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI LSRelease ( 
#ifndef LSNOPROTO 
LS_HANDLE lshandle, 
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unsigned long unused 1, 
unsigned char LSFAR *log_comment 
#endif /* LSNOPROTO */ 



); 



VDLL32 LS_STATUS_CODE VMSWINAPI LSUpdate ( 
#ifhdef LSNOPROTO 

LS_HANDLE lshandle, 

unsigned long unused 1 , 

long LSFAR *unused2, 

unsigned char LSFAR *unused3, 

LS_CHALLENGE LSFAR *unused4 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSbatchUpdate ( 

#ifhdef LSNOPROTO 
int numHandles, /* IN */ 

LS_HANDLE LSFAR * lshandle, /* INOUT - numHandles elements */ 
unsigned long LSFAR * unusedl , /* IN - should be NULL */ 
long LSFAR * unused2, /* IN - should be NULL */ 
unsigned char LSFAR * unused3, /* IN - should be NULL */ 
L SCH ALLENGE LSFAR * unused4, /* IN - should be NULL */ 
LS_STATUS_CODE LSFAR * status /* OUT - numHandles elements */ 

#endif /* LSNOPROTO */ 

); 



VDLL32 LS_STATUS_CODE VMSWINAPI VLSshutDown ( 
#ifhdef LSNOPROTO 
char LSFAR *hostName 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI LSGetMessage ( 
#ifndef LSNOPROTO 

LS_HANDLE lshandle, 

LS_STATUS_CODE Value, 

unsigned char LSFAR * Buffer, 

unsigned long BufferSize 
#endif 

); 

/* Single-call licensing. */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSlicense( 
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#ifhdefLSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR *version, 

LS_HANDLE LSFAR ""handle 
#endif /* LSNOPROTO */ 

); 

/* Disables single-call licensing; returns license key. */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSdisableLicense( 

#ifhdef LSNOPROTO 

LS_HANDLE LSFAR ""handle 
#endif /* LSNOPROTO */ 

); 

/* . */ 

/* Disables automatic renewal of license */ 
/* call with handle to disable automatic renewal of one feature */ 
/* call with (LSHANDLE) 0 to disable auto renewal of all features */ 
/* on UNIX, call VLSdisableAutoTimer before using sleep */ 
/* on Win32, call VLSdisableAutoTimer when thread has no message loop 

/* */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSdisableAutoTimer( 
#imdef LSNOPROTO 
LS HANDLE handle, 

int state /* VLS_ON or VLS_OFF */ 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetTraceLevel( 
#ifhdef LSNOPROTO 

int tracelevel 
#endif /* LSNOPROTO*/ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetContactServer( 
#ifhdef LSNOPROTO 
char LSFAR *server_name 
#endif /* LSNOPROTO */ 

); 

/* THIS FUNCTION IS OBSOLETE. Use VLSsetContactServer() instead. 
VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetServerName( 
#ifndef LSNOPROTO 

char LSFAR *server_name 
#endif /* LSNOPROTO */ 

); 
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VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetServerList ( 
#ifhdefLSNOPROTO 

char LSFAR *outBuf, 

int outBufSz 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSinitServerList( 
#ifiidef LSNOPROTO 

char LSFAR *ServerList, 

int option_flag 
#endif /* LSNOPROTO */ 

); 

/* Get the name of license server. */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetContactServer( 
#ifndef LSNOPROTO 

char LSFAR *outBuf, 

int outBufSz 
#endif 

); 

/* Get the name of license server. */ 

/* THIS FUNCTION IS OBSOLETE. Use VLSgetContactServer() instead. */ 
VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetServerName ( 
#ifndef LSNOPROTO 

char LSFAR *outBuf, 

int outBufSz 
#endif 

); 

/* Get the name of license server from Handle. */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetServerNameFromHandle ( 
#ifndef LSNOPROTO 

LS_HANDLE handle_id, 

char LSFAR *outBuf, 

int outBufSz 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSerrorHandle ( 
#ifndef LSNOPROTO 

int errorHandle 
#endif 

); 
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/* 

* Replaces the default error handler for the specified error. 

* Error Handlers are automatically called on error, unless disabled. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetErrorHandler( 
#ifndefLSNOPROTO 

LS_STATUS_CODE (VMSWINAPI * myErrorHandler)(LS_STATUS_CODE, char LSFAR 
*). 

LS_STATUS_CODE LS_ErrorType 
#endif /* LSNOPROTO */ 

); 

/* 

* Configures displaying of error msgs to the user through the default 

* error handlers. If you disable the default error handlers you do not 

* need to use this function. 

* Default behavior: 

* Windows - Pop up a Message Box. 

* Unix - Write to stderr. 

* You can alter this behavior by providing either a FILE* or a file path. 

* The other parameter should be NULL. 

* If you provide both, preference will be given to the FILE*. 
*/ 

typedef enum { 
VLS_STDOUT, VLSSTDERR 
} VLS ERR FILE ; 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetUserErrorFile( 
#ifndef LSNOPROTO 

VLS_ERR_FILE msgFile, /* IN - Desired error file */ 

char LSFAR * filePath /* IN - Full path of desired error file */ 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetRemoteRenewalTime( 
#ifndef LSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR *version, 

int renewal_time /* renewal time in sees */ 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSdiscover ( 
#ifndef LSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR * version, 
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unsigned char LSFAR *unusedl, 
int bufferSize, 
char LSFAR *server_names, 
int broadcastFlag, 
char LSFAR *vendor_list 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSwhere ( 
#ifhdefLSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR ""version, 

unsigned char LSFAR *unusedl, 

int bufferSize, 

char LSFAR *server_names, 

int broadcastFlag 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSaddFeature ( 
#ifhdefLSNOPROTO 

unsigned char LSFAR *license_string, 

unsigned char LSFAR *unusedl, 

L SCHALLENGE LSFAR *unused2 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSaddFeatureToFile ( 
#ifndefLSNOPROTO 

unsigned char LSFAR *license_string, 

unsigned char LSFAR *unusedl, 

unsigned char LSFAR *unused2, 

LS_CHALLENGE LSFAR *unused3 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSdeleteFeature ( 
#ifndefLSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR ^version, 

unsigned char LSFAR *unusedl, 

LS_CHALLENGE LSFAR *unused2 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetVersions ( 
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#ifhdefLSNOPROTO 

char LSFAR *feature_name, 

int bufferS ize, 

char LSFAR *versionList, 

char LSFAR *unusedl 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetHandlelnfo ( 
#ifhdefLSNOPROTO 

LS_HANDLE Ishandle, 

VLSclientlnfo LSFAR *client_info 
#endif 

- ); 

/* Get information about client */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetClientlnfo ( 
#ifndefLSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR *version, 

int index, 

char LSFAR *unusedl, 

VLSclientlnfo LSFAR *client_info 
#endif /* LSNOPROTO */ 

); 

/* Get information about feature */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetFeatureInfo( 
#ifhdef LSNOPROTO 

unsigned char LSFAR *feature_name, 

unsigned char LSFAR *version, 

int index, 

char LSFAR *unusedl, 

VLSfeaturelnfo LSFAR *feature_info 
#endif/* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetFeatureFromHandle ( 
#ifndef LSNOPROTO 

LS_HANDLE Ishandle, 

char LSFAR *Buffer, 

unsigned long BufferSize 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetVersionFromHandle ( 
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#ifhdefLSNOPROTO 

LS_HANDLE Ishandle, 

char LSFAR *Buffer, 

unsigned long BufferSize 
#endif 

); 

/* 

* Note that the information returned by this function will be correct 

* only immediately after acquiring the handle. The information in the 

* handle is NOT updated subsequently. 
* 

* The function is used when the clocks may not be in sync. It 

* returns the difference in seconds between the estimated current 

* time on the server and the estimated time on the client. 

* The estimation error is usually the network latency time. 

*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetTimeDriftFromHandle ( 

#ifndefLSNOPROTO 
LS_HANDLE Ishandle, /* IN */ 

long LSFAR *secondsServerAheadOfClient /* OUT */ 

#endif 

); 



/* 

* Note that the information returned by this function will be correct 

* only immediately after acquiring the handle. The information in the 

* handle is NOT updated subsequently. 

* The function is used when the clocks may not be in sync. It 

* returns the difference in seconds between the estimated current 

* time on the server and the estimated feature expiration time 

* on the server. 
* 

*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetFeatureTimeLeftFromHandle ( 

#ifndefLSNOPROTO 
LS_HANDLE Ishandle, /* IN */ 

unsigned long LSFAR *secondsUntilTheFeatureExpires /* OUT */ 

#endif 

); 
/* 

* Note that the information returned by this function will be correct 
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* only immediately after acquiring the handle. The information in the 

* handle is NOT updated subsequently. 
* 

* The function is used when the clocks may not be in sync. It 

* returns the difference in seconds between the estimated current 

* time on the server and the estimated key expiration time on 

* on the server. 
* 

*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetKeyTimeLeftFromHandle ( 

#ifodefLSNOPROTO 
LSJHANDLE lshandle, /* IN */ 

unsigned long LSFAR *secondsUntilTheKey Expires /* OUT */ 

#endif 

); 

/♦ 

* Note that the information returned by this function will be correct 

* only immediately after acquiring the handle. The information in the 

* handle is NOT updated subsequently. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetLicInUseFromHandle ( 
#ifndefLSNOPROTO 
LS_HANDLE lshandle, 

int LSFAR *totalKeysIssued /* OUT - keys issued by server */ 

#endif 

); 

/* 

* Returns the value VLS_LOCAL_UPDATE or VLS_REMOTE_UPDATE 

* depending on whether the last SUCCESSFUL update was locally done or 

* done by the SentinelLM server. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetRenewalStatus ( 
#ifndefLSNOPROTO 

void 
#endif 

); 

/* 

* Calling this function makes all future update calls 

* go directly to the SentinelLM server. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSdisableLocalRenewal( 
#ifndefLSNOPROTO 
void 
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#endif 

); 



/* 

* Calling this function allows the client libraries to process each 

* future update and send only those updates which are necessary 

* to the server. This is the default behaviour and please read the 

* user manual for further description on the default behaviour. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSenableLocalRenewal( 
#ifhdefLSNOPROTO 
void 
#endif 

); 

/* 

* This function tells us whether local renewal of keys is enabled, 

* or if all LSUpdate calls go straight to the server (disabled). 
*/ 

VDLL32 VLS_LOC_UPD_STAT VMSWINAPI VLSisLocalRenewalDisabled( 
#ifndefLSNOPROTO 
void 
#endif 

); 

/* Function to retrieve (possibly customized) hostid of the machine */ 

/* THIS FUNCTION IS OBSOLETE. Use VLSgetMachinelDO instead. */ 

VDLL32 long VMSWINAPI VLSgetHostId( 

#ifndefLSNOPROTO 

void 

#endif 

); 

/* Call this function to get a description of the client library version */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetLibInfo( 

#ifhdefLSNOPROTO 

LS_LIBVERSION LSFAR * plnfo 

#endif 

); 



VDLL32 long VMSWINAPI VLSgetNWerrno( 
#ifndefLSNOPROTO 
void 
#endif 

); 
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VDLL32 int VMSWINAPI VLSgetServerPort( 
#ifhdefLSNOPROTO 
void 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSinitialize( 
#ifhdefLSNOPROTO 

void 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLScleanup( 
#ifndefLSNOPROTO 
void 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetTimeoutlnterval ( 

#ifndefLSNOPROTO 

long interval 

#endif 

); 

VDLL32 long VMSWINAPI VLSgetTimeoutlnterval(void); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetBroadcastlnterval ( 

#ifhdefLSNOPROTO 

long interval 

#endif 

); 

VDLL32 long VMSWINAPI VLSgetBroadcastlnterval(void); 

/* call the following function at the time setup is run to install 

* application using Sentinel LM 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSinstall ( 
#ifndefLSNOPROTO 

VLSinstalllnfo LSFAR * install_info 
#endif 

); 

/* call the following function to retrieve the information 

* which was stored at setup time 
*/ 
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VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetlnstalllnfo ( 
#ifhdefLSNOPROTO 

VLSinstalllnfo LSFAR * install_info 
#endif 

); 



/* */ 

/* Fingerprinting-related types and functions: */ 
/* */ 

typedef struct _vlsmachineID { 
unsigned long id_prom; /* VLS_LOCK_ID_PROM */ 

char ip_addr[MAXLEN]; /* VLS_LOCK_IP_ADDR */ 
unsigned long diskjd; ./* VLS_LQCK_DISK_ID */ 

char host_name[MAXLEN]; /* VLS_LOCK_HOSTNAME */ 
char ethernet[MAXLEN]; /* VLS_LOCK_ETHERNET */ 
unsigned long nw_ipx; /* VLS_LOCK_NW_IPX */ 

unsigned long nw_serial; /* VLS_LOCK_NW_SERIAL */ 

char portserv_addr[MAXLEN]; /* VLS_LOCK_PORTABLE_SERV */ 
unsigned long custom; /* VLS_LOCK_CUSTOM */ 

unsigned long reserved; /* For internal use */ 

unsigned long unusedl; /* Reserved for future use. */ 

unsigned long unused2; /* Reserved for future use. */ 

} VLSmachinelD; 

/* Initializes a machine id struct to blank/default values. */ 
VDLL32 LS_STATUS_CODE VMSWINAPI VLSinitMachineID( 
#ifndefLSNOPROTO 
VLSmachinelD LSFAR *machineID /* OUT - should be pre-allocated */ 
#endif 

); 

/* 

* Sets the values of the machine id struct for the current host. 

* The input machine ID struct is initialized and then only those items 

* indicated by the lock_selector_in will (try to) be obtained and set. 

* If lock_selector_out is not NULL, *lock_selector_out is set to a bitmask 

* specifying which items could actually be obtained. 

* To try to obtain all possible machine id struct items, set 

* lock_selector_in to VLS_LOCK_ALL. 
*/ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSgetMachineID( 
#ifndefLSNOPROTO 
unsigned long lock_selector_in, /* IN */ 
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VLSmachinelD LSFAR "machinelD, /* OUT - should be pre-allocated */ 
unsigned long LSFAR *lock_selector_out/* OUT - may be NULL */ 
#endif 

); 

/* Computes locking code of macbinelD struct based on lock selector. */ 
VDLL32 LS_STATUS_CODE VMSWINAPI VLSmachineIDtoLockCode( 
#ifhdefLSNOPROTO 

VLSmachinelD LSFAR *machineID, /* IN */ 

unsigned long lock_selector, /* IN */ 

unsigned long LSFAR *lockCode /* OUT - effective locking code */ 
#endif 

); 

/* _ */ 

/* Function Prototypes of General-Purpose Utility Functions: */ 
/* */ 

/* 

* This function is called for scheduling eventhandler to be awakened after 

* so many seconds. It handles only SIGALRM signal. No. of events that can be 

* scheduled is 100. A particular eventhandler can be executed more 

* than once by specifying it in repeat_event argument. This function is 

* available only on UNIX platforms. 
*/ 

LS_STATUS_CODE VMSWINAPI VLSscheduleEvent( 
#ifndefLSNOPROTO 

unsigned long seconds, /* IN Time Interval in seconds */ 

void (*eventHandler) (void), /* IN — Signal Handler Fn. */ 

long repeat_event /* IN — No of event repetitions : 

-1 for infinite */ 

#endif 

); 
/* 

* This function is called for disabling the events scheduled using 

* VLSscheduleEvent function. To disable a particular event pass the event 

* handler function name as the argument. To disable all the events pass 

* NULL as argument. Returns LS_SUCCESS on success. This function is available 

* only on UNIX platforms. 
*/ 

LS_STATUS_CODE VMSWINAPI VLSdisableEvents( 
#ifndefLSNOPROTO 

void (*eventHandler) (void) /* IN » Signal Handler Fn.: NULL for All */ 
#endif 
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); 



/* */ 

/* Macros with default licensing values. */ 

/* There should be no space(s) between macro name and open parenthesis. */ 

/* Most of these are for backward compatibility. */ 

/* */ 



#define VLS_REQUEST(feature_name, version, handle_addr) \ 

LSRequest(LS_ANY,(unsigned char LSFAR *) "SentinelLM User", \ 
(unsigned char LSFAR *)feature_name, \ 
(unsigned char LSFAR *)version, \ 

(unsigned long LSFAR *)NULL, (unsigned char LSFAR *)NULL, \ 
(LS_CHALLENGE LSFAR *)NULL, handle_addr) 

#define VLSRELEASE(handle) \ 

LSRelease(handle, LSDEF AULTJJNITS , (unsigned char LSFAR *)NULL) 

#define VLS_UPDATE(handle) \ 

LSUpdate (handle, L S JDEF AULTJJNITS , (long LSFAR *)NULL, \ 

(unsigned char LSFAR *)NULL, (LS_CHALLENGE LSFAR *)NULL) 

#define VLS_INITIALIZEO VLSinitializeO 

#define VLS_CLEANUPQ VLScleanupQ 



/* */ 

/* Macros which will make all SentinelLM functions void: */ 
/* */ 

#ifdefNO_LICENSE 

#define LSGetMessage(al,a2,a3,a4) (LS_SUCCESS) 
#defineLSRelease(al,a2,a3) (LS_SUCCESS) 
#define LSRequest(al,a2,a3,a4,a5,a6,a7,a8) (LS_SUCCESS) 
#define LSUpdate(al,a2,a3,a4,a5) (LS_SUCCESS) 
#define VLSaddFeature(al,a2,a3) (LS_SUCCESS) 
#define VLSaddFeatureToFile(al ,a2,a3,a4) (LS_SUCCESS) 
#define VLSbatchUpdate(al,a2,a3,a4,a5,a6,a7) (LS_SUCCESS) 
#define VLScleanup() (LS_SUCCESS) 
#defme VLSdeleteFeature(al,a2,a3,a4) (LS_SUCCESS) 
#define VLSdisableAutoTimer(al,a2) (LS_SUCCESS) 
#defme VLSdisableLicense(al) (LS_SUCCESS) 
#define VLSdisableLocalRenewal() (LS_SUCCESS) 
#defme VLSdiscover(al,a2,a3,a4,a5,a6,a7) (LS_SUCCESS) 



[Iserv.h] 



#define VLSenableLocalRenewal() (LS_SUCCESS) 
#define VLSerrorHandle(al) (LS_SUCCESS) 
#define VLSgetBroadcastInterval() (9) 

#define VLSgetClientInfo(al ,a2,a3 ,a4,a5) (VLS_NO_MORE_CLIENTS) 

#define VLSgetContactServer(al,a2) (LS_SUCCESS) 

#defme VLSgetFeatureFromHandle(a 1 ,a2,a3) (LS_B ADHANDLE) 

#define VLSgetFeatureInfo(al,a2,a3,a4,a5) (VLSNOMOREFEATURES) 

#defme VLSgetFeatureTimeLeftFromHandle(al,a2) (LSBADHANDLE) 

#define VLSgetHandleInfo(al,a2) (LS_B ADHANDLE) 

#define VLSgetHostldO (0) 

#define VLSgetKeyTimeLeftFromHandle(al,a2) (LS_B ADHANDLE) 
#define VLSgetLiblnfo(al) (LS_SUCCESS) 
#define VLSgetLicInUseFromHandle(al,a2) (LSBADHANDLE) 
#define VLSgetMachineID(al,a2,a3) (LS_SUCCESS) 
#define VLSgetNWermo() (0) 

#define VLSgetRenewalStatus() (VLS_LOCAL_UPDATE) 

#define VLSgetServerList(al,a2) (LS_SUCCESS) 

#define VLSgetServerName(al,a2) (LS_SUCCESS) 

#define VLSgetServerNameFromHandle(al,a2,a3) (LS_SUCCESS) 

#define VLSgetServerPort() (5093) 

#define VLSgetTimeDriftFromHandle(al,a2) (LSBADHANDLE) 

#define VLSgetTimeoutInterval() (30) 

#define VLSgetVersionFromHandle(al,a2,a3) (LS_B ADHANDLE) 

#defme VLSgetVersions(al,a2,a3,a4) (VLS_NO_SUCH_FEATURE) 

#define VLSinitMachinelD(al) (LS_SUCCESS) 

#define VLSinitServerList(al,a2) (LS_SUCCESS) 

#define VLSinitialize() (LS_SUCCESS) 

#defme VLSinstall(al) (LS_SUCCESS) 

#define VLSisLocalRenewalDisabled() (VLS_LOCAL_UPD_ENABLE) 

#define VLSlicense(al,a2,a3) (LS_SUCCESS) 

#defme VLSmachineIDtoLockCode(al,a2,a3) (LS_SUCCESS) 

#define VLSsetBroadcastlnterval(al) (LS_SUCCESS) 

#define VLSsetContactServer(al) (LS_SUCCESS) 

#defmeVLSsetErrorHandler(al,a2) (LS_SUCCESS) 

#define VLSsetRemoteRenewalTime(al ,a2,a3) (LS_SUCCESS) 

#define VLSsetServerName(al) (LS_SUCCESS) 

#define VLSsetTimeoutInterval(a 1 ) (LS_SUCCESS) 

#define VLSsetTraceLevel(al) (LS_SUCCESS) 

#define VLSsetUserErrorFile(al,a2) (LS_SUCCESS) 

#define VLSshutDown(al) (LS_SUCCESS) 

#define VLSwhere(al,a2,a3,a4,a5,a6) (LS_SUCCESS) 

#endif /* NO LICENSE */ 



#ifdef cplusplus 

} 

#endif 
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#endif/* LSERV H */ 
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/*******************************************************************/ 

/* */ 

/* Copyright (C) 1 998 Rainbow Technologies, Inc. */ 
/* All Rights Reserved */ 

/* */ 

/* This Module contains Proprietary Information of Rainbow */ 
/* Technologies, Inc., and should be treated as Confidential. */ 

/ /*************************************************************** + + + + y 
^*pj******* ************************************************** ******* 

* FILENAME : iservcst.h 
* 

* DESCRIPTION : 

* This file contains prototypes and header declarations for 

* customizing the client/server. There are various aspects of the 

* client/server that can be customized to suit a vendor's needs. 

* This file lists all the aspects. 
* 

* USAGE : 

* All files related to customization must include this file. 

* IMPORTANT- If a vendor customizes his/her server in any way, 

* he/she must also change the port number of his/her server via 

* the API call VLSchangePortNumber(), so that the customized 

* server does not interfere with other vendors' applications that 

* rely on a default (uncustomized) server. Of course, the clients 

* must also be modified to contact the server on the new port 

* number, using the client API call VLSsetServerPort(). 
* 

* NOTES : 

* All functions in this file that are marked OVERRIDE, when present 

* in vendor's object files, will override default function bodies 

* present in static libraries of SentinelLM. For this to work 

* correctly, vendor must specify his/her overriding object files 

* BEFORE SentinelLM libraries in the linker command. These 

* functions are called by the client/server as and when needed. 

* All functions in this file that are marked BUILT-IN, are 

* functions that can be called from any vendor functions. Vendor 

* should NOT override these functions (i.e., provide his/her own 
functions by the same names). 

* All functions in this file should be customized in the same 
k manner in the standalone library as well, if the standalone 
" library is being used. 

K H */ 
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#ifhdef_LSERVCST_H 
#define _LSERVCST_H 



#ifdef cplusplus 

extern "C" { 
#endif 

#include "lserv.h" /* client API, needed for common typedefs */ 

/* */ 

/* Prototypes for client-side customization: */ 

/* r */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetHoldTime ( /* BUILT-IN */ 
#ifndefLSNOPROTO 

unsigned char LSFAR *feature_name, /* IN- */ 

unsigned char LSFAR *version, /* IN */ 

int holdjime /* IN */ 

#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetSharedld ( /* BUILT-IN */ 
#ifndefLSNOPROTO 
int sharedjd, /* IN */ 

LS_STATUS_CODE (VMSWINAPI * mySharedldFunc) (char LSFAR *) /* IN */ 
#endif 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetSharedIdValue( /* BUILT-IN */ 
#ifhdefLSNOPROTO 

int sharedjd, /* IN */ 

char LSFAR *sharedld Value /* IN */ 
#endif 

); 

VDLL32 void VMSWINAPI VLSsetServerPort( /* BUILT-IN */ 
#ifndefLSNOPROTO 



int port_number /* IN */ 

#endif 

); 

/* */ 
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/* Prototypes for client-and-server-side customization: */ 
/* */ 



/* Supply custom hostid function/mechanism */ 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSsetHostIdFunc( /* BUILT-IN */ 
#ifndefLSNOPROTO 
long (VMSWINAPI * customGetHostIdFunc)(void) /* IN */ 
#endif 

); 



/* Network messages encryption/decryption customization: */ 
int VLSencryptMsg( /* OVERRIDE */ 

#ifndefLSNOPROTO 

char *decrypted_mesg, /* IN */ 

char *encrypted_mesg, /* OUT - allocated by caller */ 

int size /* IN */ 

#endif 

); 



int VLSdecryptMsg( /* OVERRIDE */ 

#ifhdefLSNOPROTO 

char *encrypted_mesg, /* IN */ 

char *decrypted_mesg, /* OUT - allocated by caller */ 

int size /* IN */ 

#endif 

); 



/* */ 

I* Types and prototypes for server hook functions customization: */ 
/* */ 

#define HOOKLSMAXPATHLEN 128 /* Path Length */ 

#define HOOK_CLIENT_IDENTIFIER_SIZE 100 /* Client identifier size */ 

/* ***** Event types ***** */ 

#define LS_REQ_PRE 0 /* EVENT : Before processing lsreq() */ 

#define LS_REQ_POST 1 /* EVENT : After processing lsreq() */ 

#define LS REL PRE 2 /* EVENT : Before processing lsrel() */ 

#define LS_REL_POST 3 /* EVENT : After processing lsrel() */ 

/* ***** Error codes on server side ***** */ 

#define LSERV_STATUS_SUCCESS LS_SUCCESS /* Success status */ 
#define LSERV_STATUS_DENY 101 /* Denial by vendor event handler */ 
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typedef int LSERV_STATUS; 



/* Structure for File Location Info passed to vendor event handlers. */ 
typedef struct { 

char lservrcFile [HOOK_LS_MAX_PATHLEN] ; /* lservrc file path */ 
char lservrcCnfFile [HOOK_LS_MAX_P ATHLEN] ; /* lserv cnf file path */. 
char lservStaFile [HOOK_LS_MAX_P ATHLEN]; /* lserv stat file path */ 
char IservLogFile [HOOKJLS_MAX_P ATHLEN] ; /* lserv log file path */ 
char lsGrResvFile [HOOK_LS_MAX_P ATHLEN]; /* lserv group file path */ 
char reserved [HOOK_LS_MAX_P ATHLEN]; /* reserved */ 
} VLSfileLocInfo; 

/* Structure for Misc. Info passed to vendor event handlers. */ 
typedef struct { 

char ipAddress [MAX_N AME_LEN] ; /* of client*/ 

/* Flags indicate status of tests for this request: */ 
int nodeLockPass; /* 1 => Node locking tests pass */ 

int siteLicensePass; /* 1 => Site licensing tests pass */ 

int HcExpirationPass; /* 1 => License expiration tests pass */ 

int clockTamperPass; /* 1 => Clock tampering tests pass */ 

char reserved [MAX_NAME_LEN] ; 
} VLSmiscInfo; 

/* The complete structure passed to vendor event handlers. */ 
typedef struct { 

VLSclientlnfo clientlnfoStruct; /* Same as client API struct */ 
VLSfeaturelnfo featurelnfoStruct; /* Same as client API struct */ 
VLSfileLocInfo fileLocInfoStruct; 
VLSmiscInfo miscInfoStruct; 
} VLShandlerStruct; 



/* 

* Called by server during server initialization/ This is where 

* calls to VLSeventAddHookQ should be placed, to configure the server 

* to consult vendor event handler functions. 
*/ 

LSERV_STATUS VLSserverVendorInitialize( /* OVERRIDE */ 
#ifndefLSNOPROTO 

void 
#endif 

); 

/* Call to register an event handler with the server. */ 
#ifndef_VWIN31X_ 

LSERV_STATUS VLSeventAddHook( /* BUILT-IN */ 
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#ifhdefLSNOPROTO 
int eventName, /* IN - event type , LS_REQ / LSREL */ 

/*_PRE/_POST */ 
int (*handlerFuncPtr)(VLShandlerStruct *, char *, char *, int), 

/* IN - function pointer */ 
char * identifier /* IN - client identifier to match */ 
#endif 

); 

#endif 



/* */ 

/* Client-side calls to use Server Hooks: */ 
/* */ 

/* Struct passed to server from client while using server hooks: */ 
typedef struct { 
char identifier[MAX_NAME_LEN]; 

char inBuf[MAX_BUF_LEN] ; /* String passed to the server */ 
char outBufIMAX_BUF_LEN]; /* String returned by the server */ 
} VLSserverlnfo; 



VDLL32 LS_STATUS_CODE VMSWINAPI VLSinitServerlnfo ( /* BUILT-IN */ 
#ifhdef LSNOPROTO 

VLSserverlnfo LSFAR *serverInfo /* OUT - allocated by caller */ 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSrequestExt ( /* BUILT-IN */ 
#ifhdef LSNOPROTO 

unsigned char LSFAR *license_system, /* IN */ 

unsigned char LSFAR *publisher_name, /* IN */ 

unsigned char LSFAR *product_name, /* IN */ 

unsigned char LSFAR *version, /* IN */ 

unsigned long LSFAR *units_reqd, /* IN */ 

unsigned char LSFAR *log_comment, /* IN */ 

LS_CHALLENGE LSFAR *challenge, /* INOUT - allocated by caller */ 
LS_HANDLE LSFAR *lshandle, /* OUT - allocated by caller */ 
VLSserverlnfo LSFAR *serverInfo /* INOUT - allocated by caller */ 
#endif /* LSNOPROTO */ 

); 

VDLL32 LS_STATUS_CODE VMSWINAPI VLSreleaseExt ( /* BUILT-IN */ 
#ifhdef LSNOPROTO 

LS HANDLE lshandle, /* IN */ 

unsigned long unused 1, 
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unsigned char LSFAR *log_comment, /* IN */ 
VLSserverlnfo LSFAR *serverInfo /* INOUT - allocated by caller */ 
#endif /* LSNOPROTO */ 

); 



/* */ 

/* Time tamper customization (for server and standalone mode): */ 
/* */ 

typedef enum {VLSCONTAFTERTMTAMPER, VLSEXITAFTERTMTAMPER} 
VLSactionOnTmTamper; 

typedef enum { VLS_ENABLE_DEFAULT_TM_TAMPER, 
VLSJDISABLEDEFAULTTMTAMPER} 
VLStmTamperMethod; 



/* 

* Called by server each time server needs to verify whether the system 

* clock has been set back. Default behavior of the server can be 

* customized here. Note this is called BEFORE any checks are performed 

* by the server. 
*/ 

void VLSconfigureTimeTamper ( /* OVERRIDE */ 

#ifndef LSNOPROTO 

VLSactionOnTmTamper * actionOnTmTamper, /* OUT */ 

VLStmTamperMethod * tmTamperMethod, /* OUT */ 

long * gracePeriod, /* OUT */ 

int * percentViolations, /* OUT */ 

int * numViolationsForError /* OUT */ . 

#endif 

); 

/* . 

* Vendor's function to tell the server if clock has been set back. 

* Called only in case vendor's VLSconfigureTimeTamper() function returns 

* tmTamperMethod to be VLS_DISABLE_DEFAULT_TM_TAMPER, not otherwise. 

* Should return 0 if clock is not set back. 
*/ 

int VLSisClockSetBack(void); /* OVERRIDE */ 



/* */ 

/* License encryption/decryption customization (server and standalone) */ 
/* */ 
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int VLSencryptLicense( /* OVERRIDE */ 

#ifhdefLSNOPROTO 

char *decrypted_mesg, /* IN */ 

char *encrypted_mesg, /* OUT - allocated by caller */ 

int size /* IN */ 

#endif 

); 

int VLSdecryptLicense( /* OVERRIDE */ 

#ifhdefLSNOPROTO 

char *encrypted_mesg, /* IN */ 

char *decrypted_mesg, /* OUT - allocated by caller */ 

int size /* IN */ 

#endif 

); 



/* */ 

/* Server UDP port number customization: */ 
/* */ 

/* Should return the desired UDP port number of server */ 
int VLSchangePortNumber( /* OVERRIDE */ 

#imdefLSNOPROTO 



int currentPort /* IN - Currently configured port number */ 
#endif 

); 



/* */ 

/* Macros which will make all SentinelLM functions void: */ 
/* . */ 

#ifdef NO_LICENSE 

#define VLSinitServerlnfo(al) (LS_SUCCESS) 

#define VLSeventAddHook(al,a2,a3) (LS_SUCCESS) 

#define VLSreleaseExt(al ,a2,a3,a4) (LS_SUCCESS) 
#define VLSrequestExt(al,a2,a3,a4,a5,a6,a7,a8,a9) (LS_SUCCESS) 

#define VLSsetHoldTime(al,a2) (LS_SUCCESS) 

#define VLSsetHostldFunc(al) (LS_SUCCESS) 

#define VLSsetServerPort(al) /* void return */ 

#define VLSsetSharedId(al,a2) (LS_SUCCESS) 

#define VLSsetSharedIdValue(al,a2) (LS_SUCCESS) 
#endif 
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#ifdef cplusplus 

} 

#endif 



#endif /* _LSERVCST_H 
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***************************************** 

Copyright (C) 1998 by Algebron LLC. 

All rights reserved. 

Unauthorized reproduction prohibited. 
***************************************** 

Time-stamp: <1999-09-21 10:26:16 ayahil> 

PROGRAM Main 

USE Dflib, ONLY: Getarg 

USE Dfport, ONLY: Dtime, large, Time 

USE Interfaces, ONLY: Algebron, Gen_dev, Prepare, Sample 

USE Interfaces, ONLY: Get_gof 

USE Nrtype 

USE Ran_state, ONLY: Ran_seed 
USE Utils, ONLY: Bootstrap, Indgen 
IMPLICIT NONE 

! Locals 

CHARACTER, ALLOCATABLE, DIMENSION(:) :: arg*3, date*8 
INTEGER :: add_iter, cntmn, i, iarg, iboot, isim, mp, n, narg, nboot, & 

& nprob, nsim, p, pO, pstep, prn, seed, stepmx 
INTEGER, ALLOCATABLE, DIMENSION(:) :: idx, freq 
LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: msk 
REAL :: ta(2) 

REAL(sp) :: abstol, gof, gofl, gof2, gofev, gof_std, reltol, nsig, & 

& prob_avg, prob_var, prune, signif, tau 
REAL(sp), ALLOCATABLE, DIMENSION(:) :: chi2, prob, ravg, ravg_t, w, wO, z 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: r, r_t, s, stot, v, vO, vl, v2, & 

& vtot, X, x_t 

! Runtime arguments 

narg = Iargc() 

ALLOC ATE( arg(MAX(narg,l)) ) 
arg(l) = 'bin' 
DO iarg = l,narg 

CALL Getarg( iarg, arg(iarg) ) 
END DO 

! Read in sample data 
IF( arg(l) == 'asc' .OR. arg(l) == 'ASC ) THEN 
OPEN( 7, FILE='../data/amos.data', STATUS='old' ) 

OPEN( 8, FILE=*../data/amos.bin', FORM^unformatted', STATUS='unknown' ) 
READ(7,*) n, mp 
WRITE(*,*) n, mp 
WRITE(8) n, mp 

ALLOCATE( date(n), x_t(n,mp), w(n) ) 
DO i= l,n 
READ(7,*) date(i), x_t(i,:) 
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END DO 

WRITE(8) date, x_t 
CLOSE(8) 
ELSE 

OPEN( 7, FILE='../data/amos.bin', FORM^unformatted', STATUS='old* ) 
READ(7) n, mp 

ALLOCATE( date(n), x_t(n,mp), w(n) ) 
READ(7) date, x_t 
CLOSE( 7 ) 
END IF 

DEALLOCATE( arg, date ) 
WRITE(*,'(a,fl0.3)') 'Data input:', Dtime( ta ) 

! Choose computation parameters 
WRITE(*,'(a,$)') 'Enter cntmn, pO, prune, seed, tau: ' 
READ(*,*) cntmn, pO, prune, seed, tau 

IF( seed = 0 ) THEN 

CALL Ran_seed( Time() ) 
ELSE 

CALL Ran_seed( seed ) 
END IF 

IF( pO <= 0 .OR. pO > mp ) pO = mp 

pstep = mp/pO 

ALLOCATE( x(n,pO) ) 

x = x_t(:,pstep:pO*pstep:pstep) 

DEALLOCATE( x_t ) 

ALLOCATE( idx(pO), r_t(n,pO), ravg_t(pO) ) 
w = EXP( (Indgen(n) - n)/tau ) 

! Prepare daily returns 
CALL Prepare( cntmn, idx, n, p, pO, prune, r_t, ravg_t, w, x ) 
ALLOCATE( r(n,p), ravg(p) ) 
r = r_t(:,idx(:p)) 
ravg = ravg_t(idx(:p)) 
DEALLOCATE( idx, r_t, ravgj, x ) 
ALLOC ATE( chi2(n), prob(n), v(p,p), z(p*(p+l)) ) 
WRITE(*,'(a,2i5,fl0.2,lp3el5.7)') 'Initialization:', pO, p, & 

& MINVAL( r, MASK = r /= -999.0_sp ), & 

& MAXVAL( r, MASK = r /= -999.0_sp ) 

! Algebron Covariance estimate 
WRITE(*,'(a,$)') 'Enter abstol, nboot, nsig, nsim, reltol, signif, stepmx: ' 
READ(*,*) abstol, nboot, nsig, nsim, reltol, signif, stepmx 

add_iter = 1 
prn = 1 
z = 0.0_sp 

CALL Algebron( abstol, add_iter, chi2, gof, gof_ev, gof_std, n, nsig, p, & 

& prn, prob, r, reltol, signif, stepmx, v, w, z ) 
nprob = COUNT( prob /= 0.0_sp ) 
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prob_avg = SUM( prob, MASK= prob /= 0.0_sp )/nprob 
prob_var = (SUM( prob**2, MASK= prob /= 0.0_sp ) - nprob*prob_avg**2) & 
& /(nprob - 1) 

WRITE(V) *Gof, gof_ev, gofstd, prob_avg, prob_var:', & 
& gof, gof_ev, gof_std, prob_avg, prob_var, 1.0_sp/12.0_sp, & 
& 1.0_sp/SQRT( 12.0_sp*nprob) 

add_iter = 0 

! Update computation (only if no bootstrap 
! computation is done) 
IF( nboot <= 1 ) THEN 
add_iter = 0 

CALL Algebron( abstol, add_iter, chi2, gof, gof_ev, gof_std, n, nsig, p, & 

& prn, prob, r, reltol, signif, stepmx, v, w, z ) 
nprob = COUNT( prob /= 0.0_sp ) 
prob_avg = SUM( prob, MASK= prob /= 0.0_sp )/nprob 
prob_var = (SUM( prob**2, MASK= prob /= 0.0_sp ) - nprob*prob_avg**2) & 

& /(nprob - 1) 

WRITE(*,*) 'Gof, gof_ev, gof_std, prob_avg, prob_var:', & 

& gof, gof_ev, gof_std, prob_avg, prob_var, 1.0_sp/12.0_sp, & 
& 1.0_sp/SQRT( 12.0_sp*nprob) 
END IF 

! Bootstraps 
IF( nboot > 1 ) THEN 
add_iter - 1 

ALLOCATE( freq(n), vO(p,p), vl(p,p), v2(p,p), wO(n) ) 

vO = v 

vl = 0.0_sp 

v2 = 0.0_sp 

wO = w 

DO iboot= 1, nboot 
CALL Bootstrap( freq, n, seed ) 
w = wO*freq 
z = 0.0_sp 
WRITE(*,*) iboot 

CALL Algebron( abstol, add_iter, chi2, gof, gof_ev, gof_std, n, nsig, & 

& p, prn, prob, r, reltol, signif, stepmx, v, w, z ) 
vl = vl + v 
v2 = v2 + v**2 
END DO 

! Bootstrap statistics 

vl = vl /nboot 

v2 = SQRT( (v2 - nboot*vl**2)/(nboot - 1) ) 

WRITE(*,'(lp5el5.5)') vO 

WRITE(*,*) 

WRITE(*,'(lp5el5.5) , )vl 
WRITE(*,*) 
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WRITE(*,'(lp5el5.5)') v2 
WRITE(*,*) 

WRITE(*,'(lp5el5.5)') vl - vO 
WRITE(V) 

WRITE(*,'(lp5el5.5)') (vl - v0)/(v2 + TINY(v2)) 
WRITE(*,*) 

! Cleanup 

v = vO 
w = wO 

DEALLOCATE( freq, vO, vl, v2, wO ) 
END IF 

! Simulations with the same co variance matrix 
IF( nsim > 1 ) THEN 
ALLOCATE( msk(n,p), vO(p,p), vl(p,p), v2(p,p) ) 
gofl = 0.0_sp 
gof2 = 0.0_sp 
msk = (r = -999.0_sp ) 
vO = v 
vl = 0.0_sp 
v2 = 0.0_sp 

Simulationloop: DO isim = l,nsim 
CALL Gen_dev( vO, n, p, r ) 
WHERE( msk ) 
r = -999.0_sp 
END WHERE 

gof = Get_gof( chi2, gof_ev, gof_std, prob, r, vO, w ) 
WRITE(*,*) 'Simulation gof:', isim, gof, gofev, gof_std, & 

& (gof - gof_ev)/gof_std 
gofl = gofl + gof 
gof2 = gof2 + gof**2 

! Algebron method with the simulated data 

add_iter = 1 
z = 0.0_sp 
WRITE(*,*) isim 

CALL Algebron( abstol, add_iter, chi2, gof, gof_ev, gof_std, n, nsig, & 

& p, prn, prob, r, reltol, signif, stepmx, v, w, z ) 
vl = vl + v 
v2 = v2 + v**2 
END DO Simulationjoop 

! Statistics of simulations 
gofl = gofl /nsim 

gof2 = SQRT( (gof2 - nsim*gofl **2)/(nsim - 1) ) 
vl = vl/nsim 

v2 = SQRT( (v2 - nsim*vl**2)/(nsim - 1) ) 
WRITE(*,'(lp5el5.5)') vO 
WRITE(V) 
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WRITE(*,'(lp5el5.5) , )vl 
WRITE(V) 

WRITE(*,'(lp5el5.5)') v2 
WRITE(*,*) 

WRITE(*,'(lp5el5.5)')vl -vO 
WRITE(*,*) 

WRITE(*,'(lp5el5.5)') (vl - vO)*SQRT( REAL(nsim) )/(v2 + TINY(v2)) 
WRITE(*,*) 

WRITE(*,*) gofl, gof_ev, gof2, gof_std, (gofl - gof_ev)*SQRT( REAL(nsim) ) & 
& /gof_std 

! Cleanup 
DEALLOCATE( msk, vO, vl, v2 ) 
END IF 

! Cleanup 

DEALLOCATE( chi2, prob, r, ravg, v ) 
! Done 

WRITE(*, , (a,fl0.3)') 'Computation:', Dtime( ta ) 
END PROGRAM Main 
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I* ***************************************** 

/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

/* ***************************************** */ 

/* Time-stamp: <1999-09-21 10:27:53 ayahil> */ 

/* 

Sample program to demonstrate the use of the Fortran program ALGEBRON and 
auxiliary modules. PLEASE NOTE: 

1. FORTRAN PROGRAMS NEED VARIABLES BY ADDRESS, a variable has to be 
preceded by & to pass an address. However, pass a pointer as is, since it 

is already an address. 

2. C names of Fortran modules are system-dependent. On Sun* Solaris add an 
underline (J at the end of the name. 

*/ 

#include <stdio.h> 

#include <math.h> 

#include M algebron_all.h" 

#define DATA_FILENAME M ../data/amos.data M 

#define DATE_STRING_SIZE 1 0 

main() 
{ 

/* Data types */ 
char date[D ATE_STRING_SIZE] ; 

int add_iter, cntmn, mp, n, p, pO, prn, pstep, stepmx, update; /* scalar */ 
int *idx; /* 1-d*/ 

double abstol, gof, gof_ev, gof_std, nsig, prune, reltol, signif, 
tau; /* scalar */ 

double *chi2, *prob, *ravg_t, *w, *z; /* 1-d */ 
double *r, *r_n, *r J, *v, *x, *xj; /* 2-d */ 
/* Data File Pointer */ 

FILE * dfp; 

/* Data types of auxiliary variables */ 

float fl,£2,f3,f4; 
int i, il,j,k; 

/* Read in sample data */ 
dfp = fopen( DATA_FILENAME, "r" ); 
fscanf( dfp, "%d %d", &n, &mp ); 
printf( n n, mp: \t%d\t%d\n M , n, mp ); 
chi2 = (double*) malloc( sizeof( double ) * n ); 
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prob = (double*) malloc( sizeof( double ) * n ); 

w = (double*) malloc( sizeof( double ) * n ); 

x_t = (double*) malloc( sizeof( double ) * n * mp ); 

/* Read the dates and prices */ 
for( i = 0; i<n; i++ ) 

{ 

fscanf( dfp, "%s", date ); /* Read and throw away*/ 
for(j=0; j<mp;j++) 

{ 

fscanf( dfp, "%f\t", &fl ); /* Read and save */ 
x_t[j*n + i] = (double)fl; 

} 

} 

/* Enter parameters for selection of data 
subset, PREPARE parameters, and 
exponentially backward declining weights */ 

printf( "Enter cntmn pO prune tau: "); 

scanf( *'%d %d %f %f ', &cntmn, &p0, &fl, &f2 ); 

prune = (double)fl ; 

tau = (double)f2; 

if( (pO <=0) || (pO > mp ) ) pO = mp; 

pstep = mp/pO; 

if( tau =-= 0.0 ) tau = le20; 

/* Create a subset of the data */ 
x = (double*) malloc ( sizeof( double ) * n * pO); 
for( j=pstep-l, k=0; j<p0*pstep; j+=pstep, k+-f ) 
for( i=0; i < n; i++ ) 
x[n*k+i] = xj[n*j+i]; 
free( x_t ); 

/* Exponentially backward declining weights */ 

for( i=0; i<n; i++ ) 
w[i] = exp( ((double)(i-n+l))/tau ); 

/* Memory allocation for PREPARE variables */ 
idx = (int*) malloc ( sizeof( int ) * pO); 
rj= (double*) malloc ( sizeof( double ) * n * pO); 
ravg_t= (double*) malloc ( sizeof( double ) * pO); 

/* PREPARE the data, rejecting securities which 
do no meet inclusion criteria */ 
prepare_( &cntmn, idx, &n, &p, &p0, &prune, r_t, ravg_t, w, x ); 

/* Need to decrement the indices idx by one to 
bring Fortran indices (l,...,n) to C 
notation (0,...,n-l) */ 

for( i=0; i<p; i++ ) 
idx[i]»; 

/* Restrict ALGEBRON variables to the subsets 
corresponding to the valid securities */ 
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r= (double*) malloc ( sizeof( double ) * n * p); 
for(j=0;j<p;j++) 
for (i = 0; i<n; i++) 
r[n*j+i] = rJ[n*idxD]+i]; 

/* Free unneeded variables */ 

free( idx ); 
free( r_t ); 
free( ravg_t ); 
free( x ); 

/* Additional variables needed by ALGEBRON */ 
v= (double*) malloc ( sizeof( double ) * p * p); 
z= (double*) malloc ( sizeof( double ) * p * (p+1)); 

/* Initialize z to zero */ 
for (i = 0; i<(p*(p+l)); i++) 
z[i]=0.0; 

/* Read in most ALGEBRON control parameters, 
Use defaults for others. See ALGEBRON.H */ 
printf("Enter abstol nsig reltol signif stepmx: "); 
scanf( M %f %f %f %f %d M 5 &fl, &£2, &D, &f4, &il); 
abstol = (double) fl ; 
nsig = (double) £2; 
reltol = (double) O; 
signif = (double) f4; 
stepmx = il; 

/* ALGEBRON covariance estimate */ 
algebron_( &abstol, &add_iter_def, chi2, &gof, &gof_ev, &gof_std, &n, 
&nsig, &p, &prn_def ? prob, r, &reltol, &signif, 
&stepmx, v, w, z ); 

/* Print the chi-squared */ 
printf( "gof, gof_ev, gof_std: %f %f %f\n", gof, gof_ev, gof_std ); 

/* Update the ALGEBRON covariance estimate */ 

add_iter = 0; , 

algebron_( &abstol, &add_iter, chi2, &gof, &gof_ev, &gof_std, &n, &nsig 5 &p 5 
&prn_def ? prob, r, &reltol, &signif, &stepmx, v, w,z); 
/* Print the chi-squared */ 
printf( "gof, gof_ev, gof_std: %f %f %f\n M , gof, gof_ev, gof_std ); 

/* Generate fake returns with the covariance 
matrix found by ALGEBRON */ 
r_n = (double*) malloc( sizeof( double ) * n * p ); 
gen_dev_( v, &n, &p, r_n ); 
for(j=0;j<p;j+4-) 
for( i=0; i<n; i++ ) 

if( ! ( r[n*j+i] = -999.0 ) ) r[n*j+i] = r_n[n*j+i]; 
free( r_n ); 

/* Reinitialize z */ 
for (i = 0; i<(p*(p+l)); i++) 
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z[i]=0.0; 

algebronj &abstol, &add_iter_def, chi2, &gof, &gof_ev, &gof_std, &n, &nsig, 
&p, &prn_def, prob, r, &reltol, &signif, &stepmx, v, w, z ); 
/* Print the chi-squared */ 
printf( "gof, gof_ev, gof_std: %f %f %f\n", gof, gof_ev, gof_std ); 



} 
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#** Time-stamp: <1999-09-21 10:29:06 ayahil> 

# C & FORTRAN compilation & linking flags 
R8= -r8 

CFLAGS= $(COPTS) $(ENDIAN) 
FFLAGS= $(FOPTS) $(£NDIAN) 

# Local subroutine library 

SBR= libsbr$(R8)-$(HOSTTYPE).a 

# Library link symbols 
DXML= -ldxml 
IMSL= -limsl 
FITSIO= -lfitsio 

LIB= -llib$(R8)-$(HOSTTYPE) 

MINUIT= -lminuit 

MINUITL=-lminuitl 

MONGO= -lmongo 

MYNR= -lmyNR$(R8)-$(HOSTTYPE) 

NAG= -lnag$(R8) 

NR= -1NR$(R8) 

SM= -lparser -lplotsub -ldevices -lutils -1X1 1 

# Library path (/usr/lib is searched anyway, but /usr/local/lib not always) 
LPATH= -L$(HOME)/lib -L/usr/local/lib 

# Libraries to be linked (order is important) 
FLIBS= $(SBR) 

# Modules 
NRMODS= \ 

nrtype.mod 
nr. mod 
nrutil.mod 
mynr.mod 
ranstate.mod 
my_ran_state.mod 



MODS= \ 

dflib.mod \ 

dfport.mod \ 
interfaces.mod \ 

parm.mod \ 

utils.mod \ 



# Object codes of subroutines (to be placed in SBR) 
OBJS= \ 



\ 

\ 

\ 
\ 
\ 
\ 
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$(SBR)(algebron.o) 

$(SBR)(brent.o) 

$(SBR)(bootstrap.o) 

$(SBR)(choldc.o) 

$(SBR)(cholinv.o) 

$(SBR)(cholsl.o) 

$(SBR)(cml.o) 

$(SBR)(covar.o) 

$(SBR)(cull.o) 

$(SBR)(dmatmul.o) 

$(SBR)(eigsrt.o) 

$(SBR)(frprmn.o) 

$(SBR)(func.o) 

$(SBR)(gammln.o) 

$(SBR)(gammq.o) 

$(SBR)(gasdev.o) 

$(SBR)(gcf.o) 

$(SBR)(gen_covar.o) 

$(SBR)(gen_dev.o) 

$(SBR)(get_gof.o) 

$(SBR)(gser.o) 

$(SBR)(indexx.o) 

$(SBR)(indgen.o) 

$(SBR)(linmin.o) 

$(SBR)(ml.o) 

$(SBR)(mnbrak.o) 

$(SBR)(my_ranl.o) 

$(SBR)(next.o) 

$(SBR)(permute.o) 

$(SBR)(prepare.o) 

$(SBR)(pythag.o) 

$(SBR)(ranl.o) 

$(SBR)(sample.o) 

$(SBR)(sort.o) 

$(SBR)(spd.o) 

$(SBR)(tqli.o) 

$(SBR)(trace.o) 

$(SBR)(tred2.o) 

$(SBR)(wher.o) 



# Object codes of main programs (kept in the directory) 
PGMS= \ 

main.o \ 

test_func.o \ 

test_gen_covar.o \ 

test_gen_dev.o \ 
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test_gof.o \ 
test_spd.o \ 
test_wher.o \ 

# Update SBR & PGMS (default is SBR only; make compile for both) 
$(SBR): $(NRMODS) $(MODS) $(OBJS) 

ranlib $@ 
$(PGMS): $(NRMODS) $(MODS) 
compile: $(SBR) $(PGMS) 

# Executables 

$(PGMS:.o=): $(SBR) $(PGMS) 

-$(FC) $@.o $(LPATH) $(FLIBS) $(LDFLAGS) -o $@ || rm $@ 
all: $(PGMS:.o=) 

# Nonautomatic dependencies (e.g., .mod files must be set in the correct order) 
interfaces.mod: parm.mod 

# Clean the directory 
clean: 

-rm *.o $(PGMS:.o=) mon.out 
-precision "$(R8) n 
veryclean: clean 

-rm $(NRMODS) $(MODS) $(SBR) 

# Print updated .f* files 
print: print-stamp 

print-stamp: *.$(FC:77=) 
@-echo $? 

@-prl match "$?" $(PGMS:.o= $(FC:77=)y \ 
^nomatch "$?" $(PGMS:.o= $(FC:77=)) | \ 
grep -v ,A f2ctmp_ n && touch $@ & 

# Print everything 
printall: 

@-rm print-stamp 
@-make print 

# Prevent files from being erased by job interruption 
.PRECIOUS: $(SBR) $(PGMS) $(PGMS:.o=) 

# Add to the suffix list 
.SUFFIXES: .f90 

# Compilation rules 
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$(CC) $(CFLAGS) -c $< 

.f90.o: 

$(FC) $(FFLAGS) -c $< 

# Prepare module files 
.f.mod .f90.mod: 

rmlib $(SBR) $(@:.mod=) 
rmobj $(@:.mod) 
$(FC) $(FFLAGS) -c $< 
(gar ruv $(SBR) $*.o 
@rm $*.o 

# Library rules 
x.a: 

$(CC) $(CFLAGS) -c $< 
@ar ruv $@ $*.o 
@rm$*.o 
.f.a .f90.a: 

$(FC) $(FFLAGS) -c $< 
@ar ruv $@ $*.o 
@rm $*.o 



[Makefile-alpha] 



#** Time-stamp: < 1999-09-21 10:29:44 ayahil> 

# C & FORTRAN compilation & linking flags 
R8= -r8 

CFLAGS= $(COPTS) $(ENDIAN) 
FFLAGS= $(FOPTS) $(ENDIAN) 

# Local subroutine library 

SBR= libsbr$(R8)-$(HOSTTYPE).a 

# Library link symbols 
DXML= -ldxml 
IMSL= -limsl 
FITSIO= -lfitsio 

LIB= -llib$(R8)-$(HOSTTYPE) 

MINUIT= -lminuit 

MINUITL=-lminuitl 

MONGO= -lmongo 

MYNR= -lmyNR$(R8)-$(HOSTTYPE) 

NAG= -lnag$(R8) 

NR= -1NR$(R8) 

SM= -lparser -lplotsub -ldevices -lutils -1X1 1 

# Library path (/usr/lib is searched anyway, but /usr/local/lib not always) 
LPATH= -L$(HOME)/lib -L../lib -L/usr/local/lib 

# Libraries to be linked (order is important) 
FLIBS= $(SBR) -lis -lnonet -lnsl -lsocket 



# Modules 

NRMODS= \ 

nrtype.M \ 
nr.M \ 
nrutil.M \ 
mynr.M \ 
ran_state.M \ 
my_ran_state.M \ 

MODS= \ 

dflib.M \ 
dfport.M \ 
interfaces.M \ 
parm.M \ 
utils.M \ 



# Object codes of subroutines (to be placed in SBR) 
OBJS= \ 
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$(SBR)(algebron_sec.o) \ 
$(SBR)(brent.o) \ 
$(SBR)(bootstrap.o) \ 
$(SBR)(choldc.o) \ 
$(SBR)(cholinv.o) \ 
$(SBR)(cholsl.o) \ 
$(SBR)(cml.o) \ 
$(SBR)(covar.o) \ 
$(SBR)(cull.o) \ 
$(SBR)(dmatmul.o) \ 
$(SBR)(eigsrt.o) \ 
$(SBR)(frprmn.o) \ 
$(SBR)(func.o) \ 
$(SBR)(gammln.o) \ 
$(SBR)(gammq.o) \ 
$(SBR)(gasdev.o) \ 
$(SBR)(gcf.o) \ 
$(SBR)(gen_covar.o) \ 
$(SBR)(gen_dev.o) \ 
$(SBR)(get_gof.o) \ 
$(SBR)(gser.o) \ 
$(SBR)(indexx.o) \ 
$(SBR)(indgen.o) \ 
$(SBR)(linmin.o) \ 
$(SBR)(ml.o) \ 
$(SBR)(mnbrak,o) \ 
$(SBR)(my_ranl.o) \ 
$(SBR)(next.o) \ 
$(SBR)(permute.o) \ 
$(SBR)(prepare.o) \ 
$(SBR)(pythag.o) \ 
$(SBR)(ranl.o) \ 
$(SBR)(sample.o) \ 
$(SBR)(sentinel_wrapper.o) \ 
$(SBR)(sort.o) \ 
$(SBR)(spd.o) \ 
$(SBR)(tqli.o) \ 
$(SBR)(trace.o) \ 
$(SBR)(tred2.o) \ 
$(SBR)(wher.o) \ 

# Object codes of main programs (kept in the directory) 

PGMS= \ 

main.o \ 
mainc.o \ 
test func.o \ 
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test_gen_covar.o \ 
test_gen_dev.o \ 

test_gofo \ 

test_spd.o \ 

test wher.o \ 



# Update SBR & PGMS (default is SBR only; make compile for both) 
$(SBR): $(NRMODS) $(MODS) $(OBJS) 

ranlib $@ 
$(PGMS): $(NRMODS) $(MODS) 
compile: $(SBR) $(PGMS) 

# Executables 

$(PGMS:.o=): $(SBR) $(PGMS) 

-$(FC) $@.o $(LPATH) $(FLIBS) $(LDFLAGS) -o $@ || rm $@ 
all: $(PGMS:.o=) 

# Nonautomatic dependencies (e.g., .M files must be set in the correct order) 
interfaces.M: parm.M 

msc.o: algebron.h gen_dev.h prepare.h 

sentinel_wrapper.c: lserv.h lservcst.h 

# Clean the directory 
clean: 

-rm *.o $(PGMS:.o=) mon.out 
-precision M $(R8) M 
veryclean: clean 

-rm $(NRMODS) $(MODS) $(SBR) 

# Print updated .f* files 
print: print-stamp 

print-stamp : * . $(FC : 77=) 
@-echo $? 

@-prl 'match "$?" $(PGMS:.o=.$(FC:77=))' \ 
'nomatch "$?" $(PGMS:.o= $(FC:77=)) | \ 
grep -v ,A f2ctmp_ M && touch $@ & 

# Print everything 
printall: 

@-rm print-stamp 
@-make print 

# Prevent files from being erased by job interruption 
.PRECIOUS: $(SBR) $(PGMS) $(PGMS:.o=) 
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# Add to the suffix list 
.SUFFIXES: .f90 .M 

# Compilation rules 
.c.o: 

$(CC) $(CFLAGS) -c $< 

.f90.o: 

$(FC) $(FFLAGS) -c $< 

# Prepare module files 
.f.M .f90.M: 

rmlib $(SBR) $(@:.M=) 
rmobj $(@:.M) 
$(FC) $(FFLAGS) -c $< 
@arruv$(SBR)$*.o 
@rm $*.o 

# Library rules 
.c.a: 

$(CC) $(CFLAGS) -c $< 
@ar ruv $@ $*.o 
@rm $*.o 
.f.a .f90.a: 

$(FC) $(FFLAGS) -c $< 
@ar ruv $@ $*.o 
@rm $*.o 
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I***************************************** 



! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/26 21:13:25 ayahil> 

! ! Log-likelihood function and its gradient wrt to sig & lambda for factor 
!! analysis with missing data. Called by the minimization routine FRPRMN. 
!! NOTE: In this routine V is the *reduced* covariance matrix. 



FUNCTION Ml( & 
& lambda, & 
& sig, & 
& dlambda, & 
& dsig & 

& ) RESULT( out ) 



! Loading matrix 
! Independent standard deviations 

! derivative of function wrt lambda 
! derivative of function wrt sigma 



USE Interfaces, ONLY: Covar 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Diagadd, Get_diag, Outerprod 
USE Parm, ONLY: k, n, norm, p, r, sm, w 
USE Utils, ONLY: DmatmulJ, Dmatmul_r, Spd 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: sig 
REAL(sp), INTENT(in), DIMENSION(:,:) :: lambda 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION^) :: dsig 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(p,k) :: dlambda 
REAL(sp) :: out 

! Locals 
INTEGER :: chk, i, m 

INTEGER, POINTER, DIMENSION(:) :: idx 
REAL(sp) :: dnorm, ldet 

REAL(sp), ALLOCATABLE, DIMENSION(:) :: b, x 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: vinv 
REAL(sp), DIMENSION(p,p) :: v 

! Check sizes 
chk = Assert_eq( k, SIZE(lambda,2), ' Ml-k' ) 
chk = Assert_eq( n, SIZE(r,l), SIZE(sm), SIZE(w), ' Ml-n' ) 
chk = Assert_eq( (/ p, SIZE(lambda,l), SIZE(r,2), SIZE(sig), SIZE(v,l), & 

& SIZE(v,2) /), ' Ml-p' ) 
IF( PRESENT(dsig) ) THEN 

chk = Assert_eq( p, SIZE(dsig), ' Ml-p' ) 
END IF 

IF( PRESENT( dlambda) ) THEN 
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chk = Assert_eq( k, SIZE(dlambda,2), ' Ml-k' ) 
chk = Assert_eq( p, SIZE(dlambda,l), " Ml-p' ) 
END IF 

! Initialization 

norm = 0.0_sp 
out = 0.0_sp 

IF( PRESENT(dsig) ) THEN 

dsig = 0.0_sp 
END IF 

IF( PRESENT(dlambda) ) THEN 

dlambda = O.Osp 
END IF 

v = MATMUL( lambda, TRANSPOSE(lambda) ) 
CALL Diagadd( v, 1.0_sp ) 

! Log-likelihood function 
Datajoop: DO i = l,n 
idx => sm(i)%idx 
m = SIZE(idx) 
IF( m > 0 ) THEN 
ALLOCATE( b(m), x(m) ) 
b = r(i,idx)/sig(idx) 

IF( PRESENT(dsig) .OR. PRESENT(dlambda) ) THEN 
ALLOCATE( vinv(m,m) ) 

CALL Spd( v(idx,idx), ainv=vinv, b=b, ldet=ldet, x=x ) 
IF( PRESENT(dlambda) ) THEN 
dlambda(idx,:) = dlambda(idx,:) & 

& + w(i)*MATMUL( vinv - Outerprod( x, x ), lambda(idx,:) ) 
END IF 

IF( PRESENT(dsig) ) THEN 

dsig(idx) = dsig(idx) + w(i)*(1.0_sp - b*x) 
END IF 

DEALLOCATE( vinv ) 
ELSE 

CALL Spd( v(idx,idx), b=b, ldet=ldet, x=x ) 
END IF 

dnorm = DOT_PRODUCT( b, x ) 
DEALLOCATE( b, x ) 
norm = norm + w(i)* dnorm 

out = out + w(i)*(ldet + dnorm + SUM( LOG( sig(idx)**2 ) )) 
END IF 
END DO Datajoop 

! Optional gradient of likelihood function, 
! including penalty function 
IF( PRESENT(dsig) ) THEN 

dsig = 2.0_sp*dsig/sig 
END IF 



[ml.RO] 



IF( PRESENT(dlambda) ) THEN 

dlambda = 2.0_sp*dlambda 
END IF 

END FUNCTION Ml 
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I******************************************** 

Copyright (C) 1997 by Amos Yahil. 
All Rights Reserved. 

Based on (C) Numerical Recipes software, 
i******************************************** 

Time-stamp: <97/03/28 13:04:47 ayahil> 
SUBROUTINE rnnbrak(ax,bx,cx,fa,fb,fc,func,lox,hix) 
USE nrtype; USE nrutil, ONLY : nrerror,swap 
IMPLICIT NONE 

REAL(SP), INTENT(INOUT) :: ax,bx 
REAL(SP), INTENT(OUT) :: cx,fa,fb,fc 
REAL(SP), OPTIONAL, INTENT(IN) :: hix,lox 
INTERFACE 
FUNCTION func(x,dx) 

USE nrtype 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: x 

REAL(SP), OPTIONAL, INTENT(OUT) :: dx 

REAL(SP) :: rune 
END FUNCTION tunc 
END INTERFACE 

REAL(SP), PARAMETER :: GOLD=1.618034_sp,GLIMIT=100.0_sp,TINY=1.0e-20_sp 
REAL(SP) :: fu,q,r,u,ulim 
IF (PRESENT(lox)) THEN 

IF (MIN(ax,bx) < lox) CALL Nrerror( 'Mnbrak: min(ax,bx) < lox' ) 
END IF 

IF (PRESENT(hix)) THEN 

IF (MAX(ax,bx) > hix) CALL Nrerror( 'Mnbrak: max(ax,bx) > hix* ) 
END IF 
fa=func(ax) 
fb=func(bx) 
IF (fb > fa) THEN 

CALL swap(ax,bx) 

CALL swap(fa,fb) 
END IF 

cx=bx+GOLD*(bx-ax) 
IF (PRESENT(lox)) THEN 
IF (cx <= lox) THEN 
cx=lox 
RETURN 
END IF 
END IF 

IF (PRESENT(hix)) THEN 
IF (cx >= hix) THEN 
cx=hix 
RETURN 
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END IF 
END IF 
fc=func(cx) 
DO 

IF (fb < fc) RETURN 
IF (PRESENT(lox)) THEN 
IF (cx = lox) RETURN 
END IF 

IF (PRESENT(hix)) THEN 
IF (cx = hix) RETURN 
END IF 

r=(bx-ax)*(fb-fc) 
q=(bx-cx)*(fb-fa) 

u=bx-((bx-cx)*q-(bx-ax)*r)/(2.0_sp*SIGN(MAX(ABS(q-r),TINY),q-r)) 
IF (PRESENT(lox)) u=MAX(u,lox) 
IF (PRESENT(hix)) u=MIN(u,hix) 
ulim=bx+GLIMIT*(cx-bx) 
IF (PRESENT(lox)) ulim=MAX(ulim,lox) 
IF (PRESENT(hix)) ulim=MIN(ulim,hix) 
IF ((bx-u)*(u-cx) > 0.0) THEN 
fu=func(u) 
IF (fu < fc) THEN 
ax=bx 
fa=fb 
bx=u 
fb=fu 
RETURN 
ELSE IF (fu > fb) THEN 
cx=u 
fc=fu 
RETURN 
END IF 

u=cx+GOLD*(cx-bx) 
IF (PRESENT(lox)) u=MAX(u,lox) 
IF (PRESENT(hix)) u=MIN(u,hix) 
fu=func(u) 
ELSE IF ((cx-u)*(u-ulim) > 0.0) THEN 
fu=func(u) 
IF (fu < fc) THEN 

bx=cx 

cx=u 

u=cx+GOLD*(cx-bx) 
IF (PRESENT(lox)) u=MAX(u,lox) 
IF (PRESENT(hix)) u=MIN(u,hix) 
CALL shft(fb,fc,fu,func(u)) 
END IF 
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ELSE IF ((u-ulim)*(ulim-cx) >= 0.0) THEN 

u=ulim 

fu=ftinc(u) 
ELSE 

u=cx+GOLD*(cx-bx) 

IF (PRESENT(lox)) u=MAX(u,lox) 

IF (PRESENT(hix)) u=MIN(u,hix) 

fu=func(u) 
END IF 

CALL shft(ax,bx,cx,u) 
CALL shft(fa,fb,fc,fii) 
END DO 
CONTAINS 

!BL 

SUBROUTINE shft(a,b,c,d) 
REAL(SP), INTENT(OUT) :: a 
REAL(SP), INTENT(INOUT) :: b,c 
REAL(SP), INTENT(IN) :: d 
a=b 
b=c 
c=d 

END SUBROUTINE shft 
END SUBROUTINE mnbrak 
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I******************************************** 

! Copyright (C) 1997 by Amos Yahil. 
! All Rights Reserved. 

! Based on (C) Numerical Recipes software, 
i******************************************** 

! Time-stamp: <98/06/15 20:16:28 ayahil> 

MODULE mynr 

INTERFACE 
FUNCTION asolve( r ) RESULT( out ) 
USE nrtype 
IMPLICIT NONE 

REAL(DP), DIMENSIONC), INTENT(IN) :: r 
REAL(DP), DIMENSION(SIZE(r)) :: out 
END FUNCTION asolve 
END INTERFACE 

INTERFACE 
FUNCTION atimes( x ) RESULT( out ) 
USE nrtype 
IMPLICIT NONE 

REAL(DP), DIMENSIONC), INTENT(IN) :: x 
REAL(DP), DIMENSION(SIZE(x)) :: out 
END FUNCTION atimes 
END INTERFACE 

INTERFACE bcucof 
SUBROUTINE bcucof_r(y,y 1 ,y 2,y 1 2,d 1 ,d2,c) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(IN) :: dl,d2 

REAL(SP), DIMENSION^), INTENT(IN) :: y,yl,y2,yl2 
REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c 
END SUBROUTINE bcucofr 
!!!BL 

SUBROUTINE bcucof_c(y,y 1 ,y 2,y 1 2,d 1 ,d2,c) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(IN) :: dl,d2 

COMPLEX(SP), DIMENSION^) , INTENT(IN) : : y,y 1 ,y 2,y 1 2 
COMPLEX(SP), DIMENSION(4,4), INTENT(OUT) :: c 
END SUBROUTINE bcucofc 
END INTERFACE 

INTERFACE bcuint 
SUBROUTINE bcuint_r(y ,y 1 ,y2,y 1 2,x 1 l,x 1 u,x21,x2u,x 1 ,x2,ansy ,ansy 1 ,ansy2) 
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USE nrtype 
IMPLICIT NONE 

REAL(SP), DIMENSION^), INTENT(IN) :: y,yl,y2,yl2 
REAL(SP), INTENT(IN) :: xll,xlu,x21,x2u,xl,x2 
REAL(SP), INTENT(OUT) :: ansy,ansyl,ansy2 
END SUBROUTINE bcuint_r 
!!!BL 

SUBROUTINE bcuint_c(y,y 1 ,y2,y 1 2,x 1 l,x 1 u,x21,x2u,x 1 ,x2,ansy ,ansy 1 ,ansy2) 
USE nrtype 
IMPLICIT NONE 

COMPLEX(SP), DIMENSION^), INTENT(IN) :: y,yl,y2,yl2 
REAL(SP), INTENT(IN) :: xll,xlu,x21,x2u,xl,x2 
COMPLEX(SP), INTENT(OUT) : : ansy ,ansy 1 ,ansy2 
END SUBROUTINE bcuint_c 
END INTERFACE 

INTERFACE 
FUNCTION brent(ax,bx,cx,func,tol,xmin) 
USE nrtype 
IMPLICIT NONE 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: brent 
INTERFACE 
FUNCTION func(x,dx) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(IN) :: x 
REAL(SP), OPTIONAL, INTENT(OUT) :: dx 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION brent 
END INTERFACE 

INTERFACE 
FUNCTION dbrent(ax,bx,cx,func,tol,xmin) 
USE nrtype 
IMPLICIT NONE 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: dbrent 
INTERFACE 
FUNCTION func(x,dx) 

USE nrtype 

IMPLICIT NONE 
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REAL(SP), INTENT(IN) :: x 
REAL(SP), OPTIONAL, INTENT(OUT) :: dx 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION dbrent 
END INTERFACE 

INTERFACE 

SUBROUTINE dfiprmn(p,abstol,reltol,iter,fret,lop,hip,pr) 
USE nrtype 
IMPLICIT NONE 

INTEGER(I4B), INTENT(inout) :: iter 
LOGICAL, OPTIONAL, INTENT(in) :: pr 
REAL(SP), INTENT(in) :: abstol, reltol 
REAL(SP), INTENT(out) :: fret 
REAL(SP), DIMENSIONO, INTENT(inout) :: p 
REAL(SP), DIMENSIONO), OPTIONAL, INTENT(in) :: hip, lop 
END SUBROUTINE dfrprmn 
END INTERFACE 

INTERFACE 
SUBROUTINE dlinmin(p,xi,fret,dx,lop,hip) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONO, TARGET, INTENT(INOUT) :: p,xi 
REAL(SP), OPTIONAL :: dx 

REAL(SP), DIMENSIONO, OPTIONAL, INTENT(in) :: hip,lop 
END SUBROUTINE dlinmin 
END INTERFACE 

INTERFACE 

SUBROUTINE frprmn(p,abstol,reltol,iter,fret,lop,hip,ipr) 
USE nrtype 
IMPLICIT NONE 

INTEGER(I4B), INTENT(inout) :: iter 
INTEGER, OPTIONAL, INTENT(in) :: ipr 
REAL(SP), INTENT(in) :: abstol, reltol 
REAL(SP), INTENT(out) :: fret 
REAL(SP), DIMENSIONO, INTENT(inout) :: p 
REAL(SP), DIMENSIONO, OPTIONAL, INTENT(in) :: hip, lop 
END SUBROUTINE frprmn 
END INTERFACE 

INTERFACE 
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SUBROUTINE lincg(b,x,tol,itmax) 

USE nrtype 

IMPLICIT NONE 

INTEGER, INTENT(IN) :: itmax 

REAL (DP), INTENT(IN) :: tol 

REAL(DP), DIMENSIONO), INTENT(IN) :: b 

REAL (DP), DIMENSION(SIZE(b)), INTENT(INOUT) :: x 
END SUBROUTINE lincg 
END INTERFACE 

INTERFACE 
SUBROUTINE linmin(p,xi,fret,dx,lop,hip) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONO), TARGET, INTENT(INOUT) : : p,xi 
REAL(SP), OPTIONAL :: dx 

REAL(SP), DIMENSIONO), OPTIONAL, INTENT(in) :: hip,lop 
END SUBROUTINE linmin 
END INTERFACE 

INTERFACE 

SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func,lox,hix) 
USE nrtype 
IMPLICIT NONE 

REAL(SP), INTENT(INOUT) :: ax,bx 
REAL(SP), INTENT(OUT) :: cx,fa,fb,fc 
REAL(SP), OPTIONAL, INTENT(IN) :: hix,lox 
INTERFACE 
FUNCTION func(x,dx) 
USE nrtype 
IMPLICIT NONE 
REAL(SP), INTENT(IN) :: x 
REAL(SP), OPTIONAL, INTENT(OUT) :: dx 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE mnbrak 
END INTERFACE 

INTERFACE my_ranl 
SUBROUTINE my_ranl_s(harvest) 
USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE my_ranl_s 
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SUBROUTINE my_ranl_v(harvest) 
USE nrtype 

REAL(SP), DIMENSIONS, INTENT(OUT) :: harvest 
END SUBROUTINE my_ranl_v 
END INTERFACE 

END MODULE mynr 
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SUBROUTINE my_ranl_s(harvest) 
USE nrtype 

USE my_ran_state, ONLY: K4B,amm,lenran,my_ran_init, & 

iranO,jranO,kranO,nranO,mranO,rans 
IMPLICIT NONE 

REAL(SP), INTENT(OUT) :: harvest 
IF (lenran < 1) CALL my_ran_init(l) 
rans=iranO-kranO 

IF (rans < 0) rans=rans+2147483579_k4b 

iran0=jran0 

jran0=kran0 

kranO=rans 

nran0=IEOR(nran0,ISHFT(nran0, 1 3)) 
nran0=IEOR(nran0,ISHFT(nran0,- 1 7)) 
nranO=IEOR(nranO,ISHFT(nranO,5)) 
IF (nranO = 1) nran0=270369_k4b 
mranO=IEOR(mranO,ISHFT(mranO,5)) 
mranO=IEOR(mranO,ISHFT(mranO,- 1 3)) 
mranO=IEOR(rnranOJSHFT(mranO,6)) 
rans=IEOR(nranO,rans)+mranO 
harvest=amm*MERGE(rans,NOT(rans), rans<0 ) 
END SUBROUTINE my_ranl_s 

SUBROUTINE my_ranl_v(harvest) 
USE nrtype 

USE my_ran_state, ONLY: K4B,amm,Ienran,my_ran_init, & 

iranj ran,kran,nran,mran,ranv 
IMPLICIT NONE 

REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest 

INTEGER(K4B) :: n 

n=SIZE(harvest) 

IF (lenran < n+1) CALL my_ran_init(n+l) 
ranv(l :n)=iran(l :n)-kran(l :n) 

WHERE (ranv(l:n) < 0) ranv(l:n)=ranv(l:n)+2147483579_k4b 

iran(l:n)=jran(l:n) 

jran(l:n)=kran(l:n) 

kran(l :n)=ranv(l :n) 

nran(l :n)=IEOR(nran(l :n),ISHFT(nran(l :n),13)) 

nran(l :n)=IEOR(nran(l :n),ISHFT(nran(l :n),-17)) 

nran(l :n)=IEOR(nran(l :n),ISHFT(nran(l :n),5)) 

WHERE (nran(l:n) == 1) nran(l:n)=270369_k4b 

mran(l :n)=IEOR(mran(l :n),ISHFT(mran(l :n),5)) 

mran(l :n)=IEOR(mran(l :n),ISHFT(mran(l :n),-13)) 

mran(l:n)=IEOR(mran(l:n),ISHFT(mran(l:n),6)) 

ranv(l :n)=IEOR(nran(l :n),ranv(l :n))+mran(l :n) 

harvest=amm*MERGE(ranv(l:n),NOT(ranv(l:n)), ranv(l:n)<0 ) 
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END SUBROUTINE my_ranl_v 
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MODULE my_ran_state 
USE nrtype 
IMPLICIT NONE 

INTEGER, PARAMETER :: K4B=SELECTED_INT_KIND(9) 
INTEGER(K4B), PARAMETER :: hg=HUGE( 1 _K4B), hgm=-hg, hgng=hgm-l 
INTEGER(K4B), SAVE :: lenran=0, seq=0 
INTEGER(K4B), SAVE :: iranO,jranO,kranO,nranO,mranO,rans 
INTEGER(K4B), DIMENSION(:,:), POINTER, SAVE :: ranseeds 
INTEGER(K4B), DIMENSION(:), POINTER, SAVE :: iranjran,kran, & 

nran,mran,ranv 
REAL(SP), SAVE :: amm 
INTERFACE my_ran_hash 

MODULE PROCEDURE my_ran_hash_s, my_ran_hash_v 
END INTERFACE 

CONTAINS 

!BL 

SUBROUTINE my_ran_init(length) 

USE nrtype; USE nrutil, ONLY : arth,nrerror,reallocate 

IMPLICIT NONE 

INTEGER(K4B), INTENT(IN) :: length 
INTEGER(K4B) :: NEW,j,hgt 
IF (length < lenran) RETURN 
hgt=hg 

IF (hg /= 2147483647) CALL nrerror('my_ran_init: arith assump 1 fails') 
IF (hgng >= 0) CALL nrerror('my_ran_init: arith assump 2 fails') 
IF (hgt+1 /= hgng) CALL nrerror('my_ran_init: arith assump 3 fails') 
IF (NOT(hg) >= 0) CALL nrerror('my_ran_init: arith assump 4 fails') 
IF (NOT(hgng) < 0) CALL nrerror('my_ran_init: arith assump 5 fails') 
IF (hg+hgng >= 0) CALL nrerror('my_ran_init: arith assump 6 fails') 
IF (NOT(-l_k4b) < 0) CALL nrerror('my_ran_init: arith assump 7 fails') 
IF (NOT(0_k4b) >= 0) CALL nrerror('my_ran_init: arith assump 8 fails') 
IF (NOT(l_k4b) >= 0) CALL nrerror('my_ran_init: arith assump 9 fails') 
IF (lenran > 0) THEN 

ranseeds=>reallocate(ranseeds,length,5) 

ranv=>reallocate(ranv,length- 1 ) 

NEW=lenran+l 

ELSE 

ALLOCATE(ranseeds(length,5)) 
ALLOC ATE(ranv(length- 1 )) 
NEW=1 

amm=NEAREST( 1 .0_sp,- 1 .0_sp)/hgng 

IF (amm*hgng >= 1.0 .OR. amm*hgng <= 0.0) & 

CALL nrerror('my_ran_init: arth assump 1 0 fails') 

END IF 

ranseeds(NE W: , 1 )=seq 

ranseeds(NEW:,2:5)=SPREAD(arth(NEW, 1 ,SIZE(ranseeds(NEW:, 1))),2,4) 
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iranO=ranseeds( 1,1) 

jranO=ranseeds( 1 ,2) 

kranO=ranseeds( 1,3) 

mranO=ranseeds( 1 ,4) 

nranO=ranseeds( 1,5) 
ELSE IF (PRESENT(get)) THEN 

IF (lenran == 0) RETURN 

ranseeds(l,l:5)=(/ iranO,jranO,kranO,mranO,nranO f) 

get=RESHAPE(ranseeds,SHAPE(get)) 
ELSE IF (PRESENT(SEQUENCE)) THEN 

CALL my_ran_deallocate 

seq=SEQUENCE 
END IF 

END SUBROUTINE my_ran_seed 

!BL 

SUBROUTINE my_ran_hash_s(il,ir) 
IMPLICIT NONE 

INTEGER(K4B), INTENT(INOUT) :: il,ir 

INTEGER(K4B) :: is,j 

DOj=l,4 

is=ir 

ir=IEOR(ir,ISHFT(ir,5))+ 14222 17823 
ir=IEOR(ir,ISHFT(ir,-16))+1842055030 
ir=IEOR(ir,ISHFT(ir,9))+8056778 1 
ir=IEOR(il,ir) 
il=is 
END DO 

END SUBROUTINE my_ran_hash_s 

!BL 

SUBROUTINE my_ran_hash_v(il,ir) 
IMPLICIT NONE 

INTEGER(K4B), DIMENSION(:), INTENT(INOUT) :: il,ir 
INTEGER(K4B), DIMENSION(SIZE(il)) :: is 
INTEGER(K4B)::j 
DOj=l,4 

is=ir 

ir=IEOR(ir,ISHFT(ir,5))+l 4222 1 7823 
ir=IEOR(ir,ISHFT(ir,-l 6))+l 842055030 
ir=IEOR(ir,ISHFT(ir,9))+8056778 1 
ir=IEOR(il,ir) 
il=is 
END DO 

END SUBROUTINE my_ran_hash_v 
END MODULE my_ran_state 
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D0j=l,4 

CALL my_ranJiash(ranseeds(NEW:,j),ranseeds(NEW:,j+l )) 
END DO 

WHERE (ranseeds(NEW:,l :3) < 0) & 

ranseeds(NEW:, 1 :3)=NOT(ranseeds(NEW:, 1 :3)) 
WHERE (ranseeds(NEW:,4:5) = 0) ranseeds(NEW:,4:5)=l 
IF (NEW == 1) THEN 

iranO=ranseeds( 1,1) 

jranO=ranseeds(l ,2) 

kranO=ranseeds(l ,3) 

mranO=ranseeds( 1 ,4) 

nranO=ranseeds( 1,5) 

rans=nranO 
END IF 

IF (length > 1) THEN 

iran => ranseeds(2:,l) 

jran => ranseeds(2:,2) 

kran => ranseeds(2:,3) 

mran => ranseeds(2:,4) 

man => ranseeds(2:,5) 

ranv = nran 
END IF 
lenran=length 

END SUBROUTINE my_ran_init 

SUBROUTINE my_ran_deallocate 

IF (lenran > 0) THEN 

DEALLOCATE(ranseeds,ranv) 
NULLIFY(ranseeds,ranv,iranjran,kran,mran,nran) 
lenran = 0 

END IF 

END SUBROUTINE my_ran_deallocate 

SUBROUTINE my_ran_seed(SEQUENCE,size,put,get) 
IMPLICIT NONE 

INTEGER, OPTIONAL, INTENT(IN) :: SEQUENCE 
INTEGER, OPTIONAL, INTENT(OUT) : : size 
INTEGER, DIMENSIONO, OPTIONAL, INTENT(IN) :: put 
INTEGER, DIMENSIONO, OPTIONAL, INTENT(OUT) :: get 
IF (PRESENT(size)) THEN 

size=5* lenran 
ELSE IF (PRESENT(put)) THEN 

IF (lenran = 0) RETURN 

ranseeds=RESHAPE(put,SHAPE(ranseeds)) 

WHERE (ranseeds(:,l:3) < 0) ranseeds(:,l:3)=NOT(ranseeds(:,l:3)) 

WHERE (ranseeds(:,4:5) = 0) ranseeds(:,4:5)=l 
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I***************************************** 

! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited, 
i***************************************** 

! Time-stamp: <98/06/17 21:45:45 ayahil> 

! Get a new search direction from a saddle point by finding the direction 
! with the smallest negative curvature (biggest in absolute value). 
! Note, in this routine V is the ""reduced* covariance matrix. 

FUNCTION Next( & 

& z & ! Minimization variables 

& ) RESULT( out ) 

USE Nr, ONLY: Eigsrt, Tqli, Tred2 
USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Diagadd, Outerprod 
USE Parm, ONLY: k, n, p, r, sm 
USE Utils, ONLY: Spd 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: z 
REAL(sp), DIMENSIONS) :: out 

! Locals 
INTEGER :: chk, i, m 

INTEGER, DIMENSIONS, POINTER :: idx 
REAL(sp), ALLOC ATABLE, DIMENSION(:) :: x 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: vinv 
REAL(sp), DIMENSION^) :: d, e, sig 
REAL(sp), DIMENSION(p,k) :: lambda 
REAL(sp), DIMENSION(p,p) :: omega, v 

! Check sizes 
chk = Assert_eq( p*(k+ 1 ), SIZE(z), ' Next-z' ) 

! Derived sizes 

sig = z(:p) 

lambda = RESHAPE( z(p+l :), SHAPE(lambda) ) 

! Check zeroing of last factor 
IF( ANY( lambda(:,k) /= 0.0_sp ) ) & 

& STOP 'Added parameters must be initialized to zero' 

! Reduced covariance matrix 
v = MATMUL( lambda, TRANSPOSE(lambda) ) 
CALL Diagadd( v, 1 .0_sp ) 

! Second-derivative matrix (minus half of) 

omega = 0.0 
Data_loop: DO i = 1 ,n 
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idx => sm(i)%idx 
m = SIZE(idx) 
IF( m > 0 ) THEN 
ALLOCATE( vinv(m,m), x(m) ) 

CALL Spd( v(idx,idx), ainv=vinv, b=r(i,idx)/sig(idx), x=x ) 
omega(idx,idx) = omega(idx,idx) + Outerprod( x, x ) - vinv 
DEALLOCATE( vinv, x ) 
END IF 
END DO Datajoop 

! Find maximum eigenvalue/vector 
CALL Tred2( omega, d, e ) 
CALL Tqli( d, e, omega ) 
CALL Eigsrt( d, omega ) 

! Maximum eigenvector, if eigenvalue > 0 
IF( d( 1 ) > SQRT( EPSILON( 1 .0_sp ) ) ) THEN 

out = omega(:, 1 )/SQRT( d( 1 ) ) 
ELSE 

out = 0.0 
END IF 

END FUNCTION Next 
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MODULE nr 

INTERFACE 

SUBROUTINE airy(x,ai,bi,aip,bip) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP), INTENT(OUT) :: ai,bi,aip,bip 

END SUBROUTINE airy 
END INTERFACE 
INTERFACE 

SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr) 
USE nrtype 

INTEGER(I4B), INTENT(INOUT) :: iter 

REAL(SP), INTENT(INOUT) :: yb 

REAL(SP), INTENT(IN) :: ftol,temptr 

REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE amebsa 
END INTERFACE 
INTERFACE 

SUBROUTINE amoeba(p,y,ftol,func,iter) 
USE nrtype 

INTEGER(I4B), INTENT(OUT) :: iter 

REAL(SP), INTENT(IN) :: ftol 

REAL(SP), DIMENSION(:), INTENT(INOUT) :: y 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE amoeba 
END INTERFACE 
INTERFACE 

SUBROUTINE anneal(x,y,iorder) 
USE nrtype 

INTEGER(I4B), DIMENSION(:) ; INTENT(INOUT) :: iorder 
REAL(SP), DIMENSIONO), INTENT(IN) :: x,y 
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END SUBROUTINE anneal 
END INTERFACE 
INTERFACE 

SUBROUTINE asolve(b,x,itmsp) 

USE nrtype 

REAL(DP), DIMENSIONS, INTENT(IN) :: b 

REAL(DP), DIMENSIONS, INTENT(OUT) :: x 

INTEGER(I4B), INTENT(IN) :: itmsp 

END SUBROUTINE asolve 
END INTERFACE 
INTERFACE 

SUBROUTINE atimes(x,r,itmsp) 

USE nrtype 

REAL(DP), DIMENSIONS, INTENT(IN) :: x 

REAL(DP), DIMENSIONS, INTENT(OUT) :: r 

INTEGER(I4B), INTENT(IN) :: itmsp 

END SUBROUTINE atimes 
END INTERFACE 
INTERFACE 

SUBROUTINE avevar(data,ave,var) 

USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: data 

REAL(SP), INTENT(OUT) :: ave,var 

END SUBROUTINE avevar 
END INTERFACE 
INTERFACE 

SUBROUTINE balanc(a) 

USE nrtype 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a 

END SUBROUTINE balanc 
END INTERFACE 
INTERFACE 

SUBROUTINE banbks(a,ml ,m2,al,indx,b) 

USE nrtype 

TNTEGER(I4B), INTENT(IN) :: ml,m2 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx 
REAL(SP), DIMENSIONS:), INTENT(IN) :: a,al 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b 
END SUBROUTINE banbks 

END INTERFACE 

INTERFACE 

SUBROUTINE bandec(a,ml ,m2,al,indx,d) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: ml,m2 
INTEGER(I4B), DIMENSIONS, INTENT(OUT) :: indx 
REAL(SP), INTENT(OUT) :: d 
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REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 

REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al 

END SUBROUTINE bandec 
END INTERFACE 
INTERFACE 

SUBROUTINE banmul(a,ml,m2,x,b) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: ml,m2 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 

REAL(SP), DIMENSION(:), INTENT(OUT) :: b 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: a 

END SUBROUTINE banmul 
END INTERFACE 
INTERFACE 

SUBROUTINE bcucof(y,y 1 ,y2,y 1 2,d 1 ,d2,c) 

USE nrtype 

REAL(SP), INTENT(IN) :: dl,d2 

REAL(SP), DIMENSION^), INTENT(IN) :: y,yl,y2,yl2 

REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c 

END SUBROUTINE bcucof 
END INTERFACE 
INTERFACE 

SUBROUTINE bcuint(y,yl,y2,yl2,xll,xlu,x21,x2u,xl,x2,ansy,& 

ansyl,ansy2) 
USE nrtype 

REAL(SP), DIMENSION(4), INTENT(IN) :: y,yl,y2,yl2 

REAL(SP), INTENT(IN) :: xll,xlu,x21,x2u,xl,x2 

REAL(SP), INTENT(OUT) :: ansy,ansyl,ansy2 

END SUBROUTINE bcuint 
END INTERFACE 
INTERFACE beschb 

SUBROUTINE beschb_s(x,gaml ,gam2,gampl,gammi) 

USE nrtype 

REAL (DP), INTENT(IN) :: x 

REAL (DP), INTENT(OUT) :: gaml,gam2,gampl,gamrni 
END SUBROUTINE beschb_s 

!BL 

SUBROUTINE beschb_v(x,gam 1 ,gam2,gampl,gammi) 
USE nrtype 

REAL(DP), DIMENSIONC), INTENT(IN) :: x 

REAL(DP), DIMENSIONC), INTENT(OUT) :: gaml,gam2,gampl,gammi 

END SUBROUTINE beschb_v 
END INTERFACE 
INTERFACE bessi 

FUNCTION bessi_s(n,x) 

USE nrtype 
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!BL 



!BL 



!BL 



INTEGER(I4B^INTENT(IN) :: n 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessi_s 
END FUNCTION bessi_s 

FUNCTION bessi_v(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: bessi_v 
END FUNCTION bessi_v 

END INTERFACE 

INTERFACE bessiO 

FUNCTION bessiO_s(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessiO_s 
END FUNCTION bessiO_s 

FUNCTION bessiO_v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessiO_v 

END FUNCTION bessiO_v 
END INTERFACE 
INTERFACE bessil 

FUNCTION bessil_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessil_s 
END FUNCTION bessil_s 

FUNCTION bessil _v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessil_v 

END FUNCTION bessil_v 
END INTERFACE 
INTERFACE 

SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,xnu 
REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp 
END SUBROUTINE bessik 

END INTERFACE 

INTERFACE bessj 
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FUNCTION bessj_s(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessj_s 
END FUNCTION bessj_s 

!BL 

FUNCTION bessj_v(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: bessj_v 
END FUNCTION bessj_v 

END INTERFACE 

INTERFACE bessjO 

FUNCTION bessjO_s(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessjO_s 
END FUNCTION bessjO_s 

!BL 

FUNCTION bessjO_v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessjO_v 

END FUNCTION bessjO_v 
END INTERFACE 
INTERFACE bessjl 

FUNCTION bessjl_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessjl _s 
END FUNCTION bessjl_s 

!BL 

FUNCTION bessjl_v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessjl_v 

END FUNCTION bessjl_v 
END INTERFACE 
INTERFACE bessjy 

SUBROUTINE bessjy_s(x,xnu,rj ,ry,rjp,ryp) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,xnu 
REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp 
END SUBROUTINE bessjy_s 
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!BL 



SUBROUTINE bessjy_v(x,xnu,rj ,ry,rjp,ryp) 
USE nrtype 

REAL(SP), INTENT(IN) :: xnu 
REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(OUT) :: rj,rjp,ry,ryp 
END SUBROUTINE bessjy_v 

END INTERFACE 

INTERFACE bessk 

FUNCTION bessk_s(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessk_s 
END FUNCTION bessk_s 

!BL 

FUNCTION bessk_v(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: bessk_v 
END FUNCTION bessk_v 

END INTERFACE 

INTERFACE besskO 

FUNCTION besskO_s(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: besskO_s 
END FUNCTION besskO_s 

!BL 

FUNCTION besskO_v(x) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: besskO_v 

END FUNCTION besskO_v 
END INTERFACE 
INTERFACE besskl 

FUNCTION besskl_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: besskl_s 
END FUNCTION besskl_s 

!BL 

FUNCTION besskl_v(x) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
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REAL(SP), DIMENSION(size(x)) :: besskl_v 

END FUNCTION besskl_v 
END INTERFACE 
INTERFACE bessy 

FUNCTION bessy_s(n,x) 

USE mtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessy_s 
END FUNCTION bessy_s 

FUNCTION bessy_v(n,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSION(:), INTENT(IN) : : x 
REAL(SP), DIMENSION(size(x)) :: bessy_v 
END FUNCTION bessy_v 

END INTERFACE 

INTERFACE bessyO 

FUNCTION bessyO_s(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: bessyO_s 
END FUNCTION bessyO_s 

FUNCTION bessyO_v(x) 
USE nrtype 

REAL(SP), DIMENSION^, INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessyO_v 

END FUNCTION bessyO_v 
END INTERFACE 
INTERFACE bessy 1 

FUNCTION bessy l_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) ::.x 
REAL(SP) :: bessy l_s 
END FUNCTION bessy l_s 

FUNCTION bessy l_v(x) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: bessy l_v 

END FUNCTION bessy l_v 
END INTERFACE 
INTERFACE beta 

FUNCTION beta_s(z,w) 
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USE nrtype 

REAL(SP), INTENT(IN) :: z,w 
REAL(SP) :: beta_s 
END FUNCTION beta_s 

BL 

FUNCTION beta_v(z,w) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: z,w 

REAL(SP), DIMENSION(size(z)) :: beta_v 

END FUNCTION beta_v 
END INTERFACE 
INTERFACE betacf 

FUNCTION betacf_s(a,b,x) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b,x 
REAL(SP) :: betacfs 
END FUNCTION betacf_s 

BL 

FUNCTION betacf_v(a,b,x) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: a,b,x 

REAL(SP), DIMENSION(size(x)) :: betacf_v 

END FUNCTION betacf_v 
END INTERFACE 
INTERFACE betai 

FUNCTION betai_s(a,b,x) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b,x 
REAL(SP) :: betai_s 
END FUNCTION betai_s 

BL 

FUNCTION betai_v(a,b,x) 
USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: a,b,x 

REAL(SP), DIMENSION(size(a)) :: betai_v 

END FUNCTION betai_v 
END INTERFACE 
INTERFACE bico 

FUNCTION bico_s(n,k) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n,k 
REAL(SP) :: bico_s 
END FUNCTION bico_s 

BL 

FUNCTION bico_v(n,k) 
USE nrtype 
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INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k 

REAL(SP), DIMENSION(size(n)) :: bico_v 

END FUNCTION bico_v 
END INTERFACE 
INTERFACE 

FUNCTION bnldev(pp,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: pp 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP) :: bnldev 

END FUNCTION bnldev 
END INTERFACE 
INTERFACE 

FUNCTION brent(ax,bx,cx,func,tol,xmin) 

USE nrtype 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: brent 
INTERFACE 

FUNCTION fiinc(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION brent 
END INTERFACE 
INTERFACE 

SUBROUTINE broydn(x,check) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: x 

LOGIC AL(LGT), INTENT(OUT) :: check 

END SUBROUTINE broydn 
END INTERFACE 
INTERFACE 

SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: y 
REAL(SP), DIMENSIONC), INTENT(IN) :: dydx,yscal 
REAL(SP), INTENT(INOUT) :: x 
REAL(SP), INTENT(IN) :: htry,eps 
REAL(SP), INTENT(OUT) :: hdid,hnext 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
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REAL(SP), DIMENSIONO), INTENT(IN) :: y 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE bsstep 
END INTERFACE 
INTERFACE 

SUBROUTINE caldat(julian,mm,id,iyyy) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: julian 

INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy 

END SUBROUTINE caldat 
END INTERFACE 
INTERFACE 

FUNCTION chder(a,b,c) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP), DIMENSIONO), INTENT(IN) :: c 
REAL(SP), DIMENSION(size(c)) :: chder 
END FUNCTION chder 

END INTERFACE 

INTERFACE chebev 

FUNCTION chebev_s(a,b,c,x) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b,x 
REAL(SP), DIMENSIONO), INTENT(IN) :: c 
REAL(SP) :: chebev_s 
END FUNCTION chebev_s 

!BL 

FUNCTION chebev_v(a,b,c,x) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP), DIMENSIONO), INTENT(IN) :: c,x 
REAL(SP), DIMENSION(size(x)) :: chebev_v 
END FUNCTION chebev_v 

END INTERFACE 

INTERFACE 

FUNCTION chebft(a,b,n,func) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSION(n) :: chebft 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
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REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION chebft 
END INTERFACE 
INTERFACE 

FUNCTION chebpc(c) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: c 

REAL(SP), DIMENSION(size(c)) :: chebpc 

END FUNCTION chebpc 
END INTERFACE 
INTERFACE 

FUNCTION chint(a,b,c) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP), DIMENSION(:), INTENT(IN) :: c 
REAL(SP), DIMENSION(size(c)) :: chint 
END FUNCTION chint 

END INTERFACE 

INTERFACE 

SUBROUTINE choldc(a,p) 
USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 

REAL(SP), DIMENSION(:), INTENT(OUT) :: p 

END SUBROUTINE choldc 
END INTERFACE 
INTERFACE 

SUBROUTINE cholsl(a,p,b,x) 

USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: a 
REAL(SP), DIMENSIONC), INTENT(IN) :: p,b 
REAL(SP), DIMENSIONC), INTENT(INOUT) :: x 
END SUBROUTINE cholsl 

END INTERFACE 

INTERFACE 

SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: knstrn 
REAL(SP), INTENT(OUT) :: df,chsq,prob 
REAL(SP), DIMENSIONC), INTENT(IN) :: bins,ebins 
END SUBROUTINE chsone 

END INTERFACE 

INTERFACE 

SUBROUTINE chstwo(bins 1 ,bins2,knstrn,df,chsq,prob) 
USE nrtype 
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INTEGER(I4B), INTENT(IN) :: knstrn 

REAL(SP), INTENT(OUT) :: df,chsq,prob 

REAL(SP), DIMENSIONO), INTENT(IN) :: binsl,bins2 

END SUBROUTINE chstwo 
END INTERFACE 
INTERFACE 

SUBROUTINE cisi(x,ci,si) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP), INTENT(OUT) :: ci,si 

END SUBROUTINE cisi 
END INTERFACE 
INTERFACE 

SUBROUTINE cntab 1 (im,chisq,df,prob,crarnrv,ccc) 

USE nrtype 

INTEGER(I4B), DIMENSIONO,:), INTENT(IN) :: nn 
REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc 
END SUBROUTINE cntab 1 

END INTERFACE 

INTERFACE 

SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) 
USE nrtype 

INTEGER(I4B), DIMENSIONO,:), INTENT(IN) :: nn 

REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy 

END SUBROUTINE cntab2 
END INTERFACE 
INTERFACE 

FUNCTION convlv(data,respns,isign) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: data 

REAL(SP), DIMENSION(:), INTENT(IN) :: respns 

INTEGER(I4B), INTENT(IN) :: isign 

REAL(SP), DIMENSION(size(data)) :: convlv 

END FUNCTION convlv 
END INTERFACE 
INTERFACE 

FUNCTION correl(datal,data2) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: datal,data2 

REAL(SP), DIMENSION(size(datal)) :: correl 

END FUNCTION correl 
END INTERFACE 
INTERFACE 

SUBROUTINE cosftl(y) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: y 
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END SUBROUTINE cosftl 
END INTERFACE 
INTERFACE 

SUBROUTINE cosft2(y 5 isign) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: y 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE cosft2 
END INTERFACE 
INTERFACE 

SUBROUTINE covsrt(covar,maska) 

USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: covar 

LOGIC AL(LGT), DIMENSIONC), INTENT(IN) :: maska 

END SUBROUTINE covsrt 
END INTERFACE 
INTERFACE 

SUBROUTINE cyclic(a,b,c,alpha,beta,r,x) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN):: a,b,c,r 

REAL(SP), INTENT(IN) :: alpha,beta 

REAL(SP), DIMENSIONC), INTENT(OUT):: x 

END SUBROUTINE cyclic 
END INTERFACE 
INTERFACE 

SUBROUTINE daub4(a,isign) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(INOUT) :: a 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE daub4 
END INTERFACE 
INTERFACE dawson 

FUNCTION dawson_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: dawson_s 
END FUNCTION dawson_s 

FUNCTION dawson_v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: dawson_v 
END FUNCTION dawson_v 

END INTERFACE 

INTERFACE 

FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin) 



[nr.f90] 



USE nrtype 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: dbrent 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 

!BL 

FUNCTION dbrent_dfunc(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: dbrent_dfunc 
END FUNCTION dbrent_dfunc 
END INTERFACE 
END FUNCTION dbrent 
END INTERFACE 
INTERFACE 

SUBROUTINE ddpoly(c,x,pd) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(IN) :: c 
REAL(SP), DIMENSION(:), INTENT(OUT) :: pd 
END SUBROUTINE ddpoly 

END INTERFACE 

INTERFACE 

FUNCTION decchk(string,ch) 
USE nrtype 

CHARACTER(l), DIMENSION(:), INTENT(IN) :: string 

CHARACTER( 1 ), INTENT(OUT) :: ch 

LOGIC AL(LGT) :: decchk 

END FUNCTION decchk 
END INTERFACE 
INTERFACE 

SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc) 

USE nrtype 

INTEGER(I4B), INTENT(OUT) :: iter 

REAL(SP), INTENT(IN) :: gtol 

REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: p 

INTERFACE 

FUNCTION func(p) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: p 
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REAL(SP) ::func 
END FUNCTION func 

!BL 

FUNCTION dfunc(p) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: p 
REAL(SP), DIMENSION(size(p)) :: dfunc 
END FUNCTION dfunc 
END INTERFACE 
END SUBROUTINE dfpmin 
END INTERFACE 
INTERFACE 

FUNCTION dfndr(func,x,h,err) 
USE nrtype 

REAL(SP), INTENT(IN) :: x,h 
REAL(SP), INTENT(OUT) :: err 
REAL(SP) :: dfridr 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION dfridr 
END INTERFACE 
INTERFACE 

SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) 
USE nrtype 

REAL(SP), INTENT(IN) :: w,delta,a,b 
REAL(SP), INTENT(OUT) :: corre,corim,corfac 
REAL(SP), DIMENSION(:), INTENT(IN) :: endpts 
END SUBROUTINE dftcor 

END INTERFACE 

INTERFACE 

SUBROUTINE dftint(func,a,b,w,cosint,sinint) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b,w 
REAL(SP), INTENT(OUT) :: cosint,sinint 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
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END SUBROUTINE dftint 
END INTERFACE 
INTERFACE 

SUBROUTINE difeq(k,kl ,k2 Jsf,isl ,isf,indexv,s,y) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: isl,isfjsf,k,kl,k2 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: s 
REAL(SP), DIMENSIONO,:), INTENT(IN) :: y 
END SUBROUTINE difeq 

END INTERFACE 

INTERFACE 

FUNCTION eclass(lista,listb,n) 
USE nrtype 

INTEGER(I4B), DIMENSIONO), INTENT(IN) :: lista,listb 

INTEGER(I4B), INTENT(IN) :: n 

INTEGER(I4B), DIMENSION(n) :: eclass 

END FUNCTION eclass 
END INTERFACE 
INTERFACE 

FUNCTION eclazz(equiv,n) 

USE nrtype 

INTERFACE 

FUNCTION equiv(ij) 
USE nrtype 

LOGIC AL(LGT) :: equiv 

INTEGER(I4B), INTENT(IN) :: ij 

END FUNCTION equiv 
END INTERFACE 
INTEGER(I4B), INTENT(IN) :: n 
INTEGER(I4B), DIMENSION(n) :: eclazz 
END FUNCTION eclazz 
END INTERFACE 
INTERFACE 

FUNCTION ei(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP) :: ei 

END FUNCTION ei 
END INTERFACE 
INTERFACE 

SUBROUTINE eigsrt(d,v) 

USE nrtype 

REAL(SP), DIMENSIONO, INTENT(INOUT) :: d 
REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: v 
END SUBROUTINE eigsrt 
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END INTERFACE 
INTERFACE elle 

FUNCTION elle_s(phi,ak) 

USE nrtype 

REAL(SP), INTENT(IN) :: phi,ak 
REAL(SP) :: elle_s 
END FUNCTION elle_s 

!BL 

FUNCTION elle_v(phi,ak) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak 

REAL(SP), DIMENSION(size(phi)) :: elle_v 

END FUNCTION elle_v 
END INTERFACE 
INTERFACE ellf 

FUNCTION ellfs(phi,ak) 

USE nrtype 

REAL(SP), INTENT(IN) :: phi.ak 

REAL(SP)::ellf_s 

END FUNCTION ellf_s 

!BL 

FUNCTION ellf_v(phi,ak) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: phi.ak 

REAL(SP), DIMENSION(size(phi)) :: ellf_v 

END FUNCTION ellf_v 
END INTERFACE 
INTERFACE ellpi 

FUNCTION ellpi_s(phi,en,ak) 

USE nrtype 

REAL(SP), INTENT(IN) :: phi,en,ak 
REAL(SP) :: ellpi_s 
END FUNCTION ellpi_s 

!BL 

FUNCTION ellpi_v(phi,en,ak) 
USE nrtype 

REAL(SP), DIMENSION^), INTENT(IN) :: phi,en,ak 

REAL(SP), DIMENSION(size(phi)) :: ellpi_v 

END FUNCTION ellpi_v 
END INTERFACE 
INTERFACE 

SUBROUTINE elmhes(a) 

USE nrtype 

REAL(SP), DIMENSION^:), INTENT(INOUT) :: a 
END SUBROUTINE elmhes 
END INTERFACE 
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INTERFACE erf 

FUNCTION erf_s(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: erf_s 
END FUNCTION erfs 

!BL 

FUNCTION erf_v(x) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: erf_v 

END FUNCTION erfv 
END INTERFACE 
INTERFACE erfc 

FUNCTION erfc_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: erfc_s 
END FUNCTION erfc_s 

!BL 

FUNCTION erfc_v(x) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: erfc_v 

END FUNCTION erfc_v 
END INTERFACE 
INTERFACE erfcc 

FUNCTION erfcc_s(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: erfcc_s 
END FUNCTION erfcc_s 

!BL 

FUNCTION erfcc_v(x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: erfcc_v 

END FUNCTION erfcc_v 
END INTERFACE 
INTERFACE 

SUBROUTINE eulsum(sum,term,jterm) 

USE nrtype 

REAL(SP), INTENT(INOUT) :: sum 
REAL(SP), INTENT(IN) :: term 
INTEGER(I4B), INTENT(IN) :: jterm 
END SUBROUTINE eulsum 
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END INTERFACE 
INTERFACE 

FUNCTION evlmem(fdt,d,xms) 

USE nrtype 

REAL(SP), INTENT(IN) :: fdt,xms 

REAL(SP), DIMENSIONC), INTENT(IN) :: d 

REAL(SP) :: evlmem 

END FUNCTION evlmem 
END INTERFACE 
INTERFACE expdev 

SUBROUTINE expdev_s(harvest) 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE expdev_s 

!BL 

SUBROUTINE expdev_v(harvest) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(OUT) :: harvest 

END SUBROUTINE expdev_v 
END INTERFACE 
INTERFACE 

FUNCTION expint(n,x) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP), INTENT(IN) :: x 

REAL(SP) :: expint 

END FUNCTION expint 
END INTERFACE 
INTERFACE factln 

FUNCTION factln_s(n) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP) :: factln_s 
END FUNCTION factln_s 

!BL 

FUNCTION factln_v(n) 
USE nrtype 

INTEGER(I4B), DIMENSIONC), INTENT(IN) :: n 

REAL(SP), DIMENSION(size(n)) :: factln_v 

END FUNCTION factln_v 
END INTERFACE 
INTERFACE factrl 

FUNCTION factrl_s(n) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP) :: factrl_s 



[nr.f90] 



END FUNCTION factrl_s 



FUNCTION factriv(n) 
USE nrtype 

INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n 
REAL(SP), DIMENSION(size(n)) :: factrl_v 
END FUNCTION factrl_v 

END INTERFACE 

INTERFACE 

SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y 

REAL(SP), INTENT(IN) :: ofac,hifac 

INTEGER(I4B), INTENT(OUT) :: jmax 

REAL(SP), INTENT(OUT) :: prob 

REAL(SP), DIMENSION(:), POINTER :: px,py 

END SUBROUTINE fasper 
END INTERFACE 
INTERFACE 

SUBROUTINE fdjac(x,fvec,df) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: fvec 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x 
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df 
END SUBROUTINE fdjac 

END INTERFACE 

INTERFACE 

SUBROUTINE fgauss(x,a,y,dyda) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,a 
REAL(SP), DIMENSION(:), INTENT(OUT) :: y 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: dyda 
END SUBROUTINE fgauss 

END INTERFACE 

INTERFACE 

SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y 
REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q 
REAL(SP), DIMENSIONO), OPTIONAL, INTENT(IN) :: 
END SUBROUTINE fit 

END INTERFACE 

INTERFACE 

SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y,sigx,sigy 



REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q 

END SUBROUTINE fitexy 
END INTERFACE 
INTERFACE 

SUBROUTINE fixrts(d) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: d 

END SUBROUTINE fixrts 
END INTERFACE 
INTERFACE 

FUNCTION fleg(x,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP), DIMENSION(n) :: fleg 

END FUNCTION fleg 
END INTERFACE 
INTERFACE 

SUBROUTINE flmoon(n,nph,jd,frac) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n,nph 

INTEGER(I4B), INTENT(OUT) :: jd 

REAL(SP), INTENT(OUT) :: frac 

END SUBROUTINE flmoon 
END INTERFACE 
INTERFACE fourl 

SUBROUTINE fourl_sp(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourl_sp 
END INTERFACE 
INTERFACE 

SUBROUTINE fourl_alt(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONO), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourl_alt 
END INTERFACE 
INTERFACE 

SUBROUTINE four 1 _gather(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONO), INTENT(INOUT) :: data 
INTEGER(I4B), INTENT(IN) :: isign 
END SUBROUTINE fourl_gather 
END INTERFACE 
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INTERFACE 

SUBROUTINE four2(data,isign) 
USE nrtype 

' COMPLEX(SPC), DIMENSION(:,:) 3 INTENT(INOUT) :: data 

INTEGER(I4B),INTENT(IN) :: isign 

END SUBROUTINE four2 
END INTERFACE 
INTERFACE 

SUBROUTINE four2_a!t(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONO,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE four2_alt 
END INTERFACE 
INTERFACE 

SUBROUTINE four3(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data 

INTEGER(I4B),INTENT(IN) :: isign 

END SUBROUTINE four3 
END INTERFACE 
INTERFACE 

SUBROUTINE four3_alt(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE four3_alt 
END INTERFACE 
INTERFACE 

SUBROUTINE fourcol(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourcol 
END INTERFACE 
INTERFACE 

SUBROUTINE fourcol_3d(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONO,:,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourcol_3d 
END INTERFACE 
INTERFACE 

SUBROUTINE fourn_gather(data,nn,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data 
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INTEGER(I4B), DIMENSIONC), INTENT(IN) :: nn 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourn_gather 
END INTERFACE 
INTERFACE fourrow 

SUBROUTINE fourrow_sp(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONC,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourrow_sp 
END INTERFACE 
INTERFACE 

SUBROUTINE fourrow_3d(data,isign) 

USE nrtype 

COMPLEX(SPC), DIMENSIONC,:,:), INTENT(INOUT) :: data 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE fourrow_3d 
END INTERFACE 
INTERFACE 

FUNCTION fpoly(x,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP), DIMENSION(n) :: fpoly 

END FUNCTION fpoly 
END INTERFACE 
INTERFACE 

SUBROUTINE fred2(a,b,t,f,w,g,ak) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 

REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w 

INTERFACE 

FUNCTION g(t) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: t 
REAL(SP), DIMENSION(size(t)) :: g 
END FUNCTION g 

!BL 

FUNCTION ak(t,s) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: t,s 
REAL(SP), DIMENSION(size(t),size(s)) :: ak 
END FUNCTION ak 

END INTERFACE 

END SUBROUTINE fred2 
END INTERFACE 
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INTERFACE 

FUNCTION fredin(x,a,b,t,f,w,g,ak) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 

REAL(SP), DIMENSIONC), INTENT(IN) :: x,t,f,w 

REAL(SP), DIMENSION(size(x)) :: fredin 

INTERFACE 

FUNCTION g(t) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: t 
REAL(SP), DIMENSION(size(t)) :: g 
END FUNCTION g 

FUNCTION ak(t,s) 
USE nrtype 

REAL(SP), DIMENSION^, INTENT(IN) :: t,s 
REAL(SP), DIMENSION(size(t),size(s)) :: ak 
END FUNCTION ak 
END INTERFACE 
END FUNCTION fredin 
END INTERFACE 
INTERFACE 

SUBROUTINE frenel(x,s,c) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP), INTENT(OUT) :: s,c 

END SUBROUTINE frenel 
END INTERFACE 
INTERFACE 

SUBROUTINE frprmn(p,ftol,iter,fret) 

USE nrtype 

INTEGER(I4B), INTENT(OUT) :: iter 

REAL(SP), INTENT(IN) :: ftol 

REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONC), INTENT(INOUT) : : p 

END SUBROUTINE frprmn 
END INTERFACE 
INTERFACE 

SUBROUTINE ftest(datal ,data2,f,prob) 

USE nrtype 

REAL(SP), INTENT(OUT) :: f,prob 

REAL(SP), DIMENSIONC), INTENT(IN) :: datal,data2 

END SUBROUTINE ftest 
END INTERFACE 
INTERFACE 

FUNCTION gamdev(ia) 
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USE nrtype 

INTEGER(I4B), INTENT(IN) :: ia 

REAL(SP) :: gamdev 

END FUNCTION gamdev 
END INTERFACE 
INTERFACE gammln 

FUNCTION gammln_s(xx) 

USE nrtype 

REAL(SP), INTENT(IN) :: xx 
REAL(SP) :: gammln_s 
END FUNCTION gammln_s 

FUNCTION gammln_v(xx) 
USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: xx 

REAL(SP), DIMENSION(size(xx)) :: gammln_v 

END FUNCTION gammln_v 
END INTERFACE 
INTERFACE gammp 

FUNCTION gammp_s(a,x) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,x 
REAL(SP) :: gammp_s 
END FUNCTION gammp_s 

FUNCTION gammp_v(a,x) 
USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: a,x 

REAL(SP), DIMENSION(size(a)) :: gammp_v 

END FUNCTION gammp_v 
END INTERFACE 
INTERFACE gammq 

FUNCTION gammq_s(a,x) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,x 
REAL(SP) :: gammq_s 
END FUNCTION gammq_s 

FUNCTION gammq_v(a,x) 
USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: a,x 

REAL(SP), DIMENSION(size(a)) :: gammq_v 

END FUNCTION gammq_v 
END INTERFACE 
INTERFACE gasdev 

SUBROUTINE gasdev_s(harvest) 
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t 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE gasdev_s 

!BL 

SUBROUTINE gasdev_v(harvest) 
USE nrtype 

REAL(SP), DIMENSIONO, INTENT(OUT) :: harvest 

END SUBROUTINE gasdev_v 
END INTERFACE 
INTERFACE 

SUBROUTINE gaucof(a,b,amuO,x,w) 

USE nrtype 

REAL(SP), INTENT(IN) :: amuO 

REAL(SP), DIMENSIONO, INTENT(INOUT) :: a,b 

REAL(SP), DIMENSIONO, INTENT(OUT) :: x,w 

END SUBROUTINE gaucof 
END INTERFACE 
INTERFACE 

SUBROUTINE gauher(x,w) 

USE nrtype 

REAL(SP), DIMENSIONO, INTENT(OUT) :: x,w 

END SUBROUTINE gauher 
END INTERFACE 
INTERFACE 

SUBROUTINE gaujac(x,w,alf,bet) 

USE nrtype 

REAL(SP), INTENT(IN) :: alf,bet 

REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w 

END SUBROUTINE gaujac 
END INTERFACE 
INTERFACE 

SUBROUTINE gaulag(x,w,alf) 

USE nrtype 

REAL(SP), INTENT(IN) :: alf 

REAL(SP), DIMENSIONO, INTENT(OUT) :: x,w 

END SUBROUTINE gaulag 
END INTERFACE 
INTERFACE 

SUBROUTINE gauleg(xl,x2,x,w) 

USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2 

REAL(SP), DIMENSIONO, INTENT(OUT) :: x,w 

END SUBROUTINE gauleg 
END INTERFACE 
INTERFACE 

SUBROUTINE gaussj(a,b) 
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USE nrtype 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b 

END SUBROUTINE gaussj 
END INTERFACE 
INTERFACE gcf 

FUNCTION gcf_s(a,x,gln) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,x 
REAL(SP), OPTIONAL, INTENT(OUT) :: gin 
REAL(SP) :: gcf_s 
END FUNCTION gcf_s 

!BL 

FUNCTION gcf_v(a,x,gln) 
USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: a,x 

REAL(SP), DIMENSIONS), OPTIONAL, TNTENT(OUT) : : gin 

REAL(SP), DIMENSION(size(a)) :: gcf_v 

END FUNCTION gcfv 
END INTERFACE 
INTERFACE 

FUNCTION golden(ax,bx,cx,func,tol,xmin) 

USE nrtype 

REAL(SP), INTENT(IN) :: ax,bx,cx,tol 
REAL(SP), INTENT(OUT) :: xmin 
REAL(SP) :: golden 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP)::func 
END FUNCTION func 
END INTERFACE 
END FUNCTION golden 
END INTERFACE 
INTERFACE gser 

FUNCTION gser_s(a,x,gln) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,x 
REAL(SP), OPTIONAL, INTENT(OUT) :: gin 
REAL(SP) :: gser_s 
END FUNCTION gser_s 

!BL 

FUNCTION gser_v(a,x,gln) 
USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: a,x 

REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gin 
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REAL(SP), DfliENSION(size(a)) :: gser_v 

END FUNCTION gser_v 
END INTERFACE 
INTERFACE 

SUBROUTINE hqr(a,wr,wi) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(OUT) :: wr,wi 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 

END SUBROUTINE hqr 
END INTERFACE 
INTERFACE 

SUBROUTINE hunt(xx,x,jlo) 

USE nrtype 

INTEGER(I4B), INTENT(INOUT) :: jlo 

REAL(SP), INTENT(IN) : : x 

REAL(SP), DIMENSION^, INTENTflN) :: xx 

END SUBROUTINE hunt 
END INTERFACE 
INTERFACE 

SUBROUTINE hypdrv(s,ry,rdyds) 

USE nrtype 

REAL(SP), INTENT(IN) :: s 

REAL(SP), DIMENSIONC), INTENT(IN) :: ry 

REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds 

END SUBROUTINE hypdrv 
END INTERFACE 
INTERFACE 

FUNCTION hypgeo(a,b,c,z) 

USE nrtype 

COMPLEX(SPC), INTENT(IN) :: a,b,c,z 

COMPLEX(SPC) :: hypgeo 

END FUNCTION hypgeo 
END INTERFACE 
INTERFACE 

SUBROUTINE hypser(a,b,c,z,series,deriv) 

USE nrtype 

COMPLEX(SPC), INTENT(IN) :: a,b,c,z 

COMPLEX(SPC), INTENT(OUT) :: series,deriv 

END SUBROUTINE hypser 
END INTERFACE 
INTERFACE 

FUNCTION icrc(crc,buf,jinit,jrev) 

USE nrtype 

CHARACTER(l), DIMENSIONC), INTENT(IN) :: buf 
INTEGER(I2B), INTENT(IN) :: crcjinit 
INTEGER(I4B), INTENT(IN) :: jrev 



INTEGER(I2B~icrc 

END FUNCTION icrc 
END INTERFACE 
INTERFACE 

FUNCTION igray(n,is) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n,is 

INTEGER(I4B) :: igray 

END FUNCTION igray 
END INTERFACE 
INTERFACE 

RECURSIVE SUBROUTINE index_bypack(arr,index,partial) 
USE nrtype 

REAL(SP), DIMENSIONS INTENT(IN) :: arr 

INTEGER(I4B), DIMENSIONC), INTENT(INOUT) : : index 

INTEGER, OPTIONAL, INTENT(IN) :: partial 

END SUBROUTINE index_bypack 
END INTERFACE 
INTERFACE indexx 

SUBROUTINE indexx_sp(arr,index) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: arr 
INTEGER(I4B), DIMENSIONC), INTENT(OUT) :: index 
END SUBROUTINE indexx_sp 
SUBROUTINE indexx_i4b(iarr,index) 
USE nrtype 

INTEGER(I4B), DIMENSIONC), INTENT(IN) :: iarr 

INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index 

END SUBROUTINE indexx_i4b 
END INTERFACE 
INTERFACE 

FUNCTION interp(uc) 

USE nrtype 

REAL(DP), DIMENSIONC,:), INTENT(IN) :: uc 

REAL(DP), DIMENSION(2*size(uc,l)-l,2*size(uc,l)-l) :: interp 

END FUNCTION interp 
END INTERFACE 
INTERFACE 

FUNCTION rank(indx) 

USE nrtype 

INTEGER(I4B), DIMENSIONC), INTENT(IN) :: indx 

INTEGER(I4B), DIMENSION(size(indx)) :: rank 

END FUNCTION rank 
END INTERFACE 
INTERFACE 

FUNCTION irbitl(iseed) 
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USE nrtype 

INTEGER(I4B), INTENT(INOUT) :: iseed 

INTEGER(I4B) :: irbitl 

END FUNCTION irbitl 
END INTERFACE 
INTERFACE 

FUNCTION irbit2(iseed) 

USE nrtype 

INTEGER(I4B), INTENT(INOUT) :: iseed 

INTEGER(I4B) :: irbit2 

END FUNCTION irbit2 
END INTERFACE 
INTERFACE 

SUBROUTINE jacobi(a,d,v,nrot) 

USE nrtype 

INTEGER(I4B), INTENT(OUT) :: nrot 
REAL(SP), DIMENSIONC), INTENT(OUT) :: d 
REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 
REAL(SP), DIMENSIONC,:), INTENT(OUT) :: v 
END SUBROUTINE jacobi 

END INTERFACE 

INTERFACE 

SUBROUTINE jacobn(x,y,dfdx,dfdy) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP), DIMENSIONC), INTENT(IN) :: y 

REAL(SP), DIMENSIONC), INTENT(OUT) :: dfdx 

REAL(SP), DIMENSIONC,:), INTENT(OUT) :: dfdy 

END SUBROUTINE jacobn 
END INTERFACE 
INTERFACE 

FUNCTION julday(mm,id,iyyy) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: mm,id,iyyy 

INTEGER(I4B) :: julday 

END FUNCTION julday 
END INTERFACE 
INTERFACE 

SUBROUTINE kendl 1 (datal ,data2,tau,z,prob) 

USE nrtype 

REAL(SP), INTENT(OUT) :: tau,z,prob 

REAL(SP), DIMENSIONC), INTENT(IN) :: datal ,data2 

END SUBROUTINE kendl 1 
END INTERFACE 
INTERFACE 

SUBROUTINE kendl2(tab,tau,z,prob) 
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USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: tab 

REAL(SP), INTENT(OUT) :: tau,z,prob 

END SUBROUTINE kendl2 
END INTERFACE 
INTERFACE 

FUNCTION kermom(y,m) 

USE nrtype 

REAL(DP), INTENT(IN) :: y 

INTEGER(I4B), INTENT(IN) :: m 

REAL(DP), DIMENSION(m) :: kermom 

END FUNCTION kermom 
END INTERFACE 
INTERFACE 

SUBROUTINE ks2d 1 s(x 1 ,y 1 ,quadvl,d 1 ,prob) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: xl.yl 
REAL(SP), INTENT(OUT) :: dl,prob 
INTERFACE 

SUBROUTINE quadvl(x,y,fa,fb,fc,fd) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,y 
REAL(SP), INTENT(OUT) :: fa,fb,fc,fd 
END SUBROUTINE quadvl 

END INTERFACE 

END SUBROUTINE ks2dls 

END INTERFACE 

INTERFACE 

SUBROUTINE ks2d2s(xl,yl,x2,y2,d,prob) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: xl,yl,x2,y2 

REAL(SP), INTENT(OUT) :: d,prob 

END SUBROUTINE ks2d2s 
END INTERFACE 
INTERFACE 

SUBROUTINE ksone(data,func,d,prob) 

USE nrtype 

REAL(SP), INTENT(OUT) :: d,prob 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: data 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
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END SUBROUTINE ksone 
END INTERFACE 
INTERFACE 

SUBROUTINE kstwo(datal ,data2,d,prob) 

USE nrtype 

REAL(SP), INTENT(OUT) :: d,prob 

REAL(SP), DIMENSIONO), INTENT(IN) :: datal,data2 

END SUBROUTINE kstwo 
END INTERFACE 
INTERFACE 

SUBROUTINE laguer(a,x,its) 

USE nrtype 

INTEGER(I4B), INTENT(OUT) :: its 

COMPLEX(SPC), INTENT(INOUT) :: x 

COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a 
. END SUBROUTINE laguer 
END INTERFACE 
INTERFACE 

SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y,sig 
REAL(SP), DIMENSIONO), INTENT(INOUT) :: a 
LOGIC AL(LGT), DIMENSIONO), INTENT(IN) :: maska 
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar 
REAL(SP), INTENT(OUT) :: chisq 
INTERFACE 

SUBROUTINE funcs(x,arr) 

USE nrtype 

REAL(SP),INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(OUT) :: arr 
END SUBROUTINE funcs 
END INTERFACE 
END SUBROUTINE lfit 
END INTERFACE 
INTERFACE 

SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err) 
USE nrtype 

REAL(DP), DIMENSIONO), INTENT(IN) :: b 

REAL(DP), DIMENSION(:), INTENT(INOUT) :: x 

INTEGER(I4B), INTENT(IN) :: itol,itmax 

REAL (DP), INTENT(IN) :: tol 

INTEGER(I4B), INTENT(OUT) :: iter 

REAL(DP), INTENT(OUT) :: err 

END SUBROUTINE linbcg 
END INTERFACE 
INTERFACE 
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SUBROUTINE linmin(p,xi,fret) 
USE nrtype 

REAL(SP), INTENT(OUT) :: fret 

REAL(SP), DIMENSIONC), TARGET, INTENT(INOUT) :: p,xi 

END SUBROUTINE linmin 
END INTERFACE 
INTERFACE 

SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: xold,g 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: p 

REAL(SP), INTENT(IN) :: fold,stpmax 

REAL(SP), DIMENSION(:), INTENT(OUT) :: x 

REAL(SP), INTENT(OUT) :: f 

LOGIC AL(LGT), INTENT(OUT) :: check 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP) :: func 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE lnsrch 
END INTERFACE 
INTERFACE 

FUNCTION locate(xx,x) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: xx 

REAL(SP), INTENT(IN) :: x 

INTEGER(I4B) :: locate 

END FUNCTION locate 
END INTERFACE 
INTERFACE 

FUNCTION lop(u) 

USE nrtype 

REAL(DP), DIMENSIONC,:), INTENT(IN) :: u 

REAL(DP), DIMENSION(size(u,l),size(u,l)) :: lop 

END FUNCTION lop 
END INTERFACE 
INTERFACE 

SUBROUTINE lubksb(a,indx,b) 

USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: a 
INTEGER(I4B), DIMENSIONC), INTENT(IN) :: indx 
REAL(SP), DIMENSIONC), INTENT(INOUT) :: b 
END SUBROUTINE lubksb 
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END INTERFACE 
INTERFACE 

SUBROUTINE ludcmp(a,indx,d) 

USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: a 

INTEGER(I4B), DIMENSIONO), INTENT(OUT) :: indx 

REAL(SP), INTENT(OUT) :: d 

END SUBROUTINE ludcmp 
END INTERFACE 
INTERFACE 

SUBROUTINE machar(ibeta,it,imd,ngrd,machep,negep,iexp,minexp,& 

maxexp,eps,epsneg,xmin,xmax) 
USE nrtype 

INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,imd,it,machep,maxexp,& 
minexp,negep,ngrd 

REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin 

END SUBROUTINE machar 
END INTERFACE 
INTERFACE 

SUBROUTINE medfit(x,y,a,b,abdev) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y 

REAL(SP), INTENT(OUT) :: a,b,abdev 

END SUBROUTINE medfit 
END INTERFACE 
INTERFACE 

SUBROUTINE memcof(data,xms,d) 

USE nrtype 

REAL(SP), INTENT(OUT) :: xms 

REAL(SP), DIMENSIONO), INTENT(IN) :: data 

REAL(SP), DIMENSION^:), INTENT(OUT) :: d 

END SUBROUTINE memcof 
END INTERFACE 
INTERFACE 

SUBROUTINE mgfas(u,maxcyc) 

USE nrtype 

REAL(DP), DIMENSIONO,:), INTENT(INOUT) :: u 

INTEGER(I4B), INTENT(IN) :: maxcyc 

END SUBROUTINE mgfas 
END INTERFACE 
INTERFACE 

SUBROUTINE mglin(u,ncycle) 

USE nrtype 

REAL(DP), DIMENSIONO,:), INTENT(INOUT) :: u 
INTEGER(I4B), INTENT(IN) :: ncycle 
END SUBROUTINE mglin 
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END INTERFACE 
INTERFACE 

SUBROUTINE midexp(funk,aa,bb,s,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: aa,bb 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION funk(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: funk 
END FUNCTION funk 
END INTERFACE 
END SUBROUTINE midexp 
END INTERFACE 
INTERFACE 

SUBROUTINE midinf(funk,aa,bb,s,n) 
USE nrtype 

REAL(SP), INTENT(IN) :: aa,bb 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION funk(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: funk 
END FUNCTION funk 
END INTERFACE 
END SUBROUTINE midinf 
END INTERFACE 
INTERFACE 

SUBROUTINE midpnt(func,a,b,s,n) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 

END INTERFACE 

END SUBROUTINE midpnt 
END INTERFACE 
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INTERFACE 

SUBROUTINE midsql(funk,aa,bb,s,n) 
USE nrtype 

REAL(SP), INTENT(IN) :: aa,bb 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION funk(x) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: funk 
END FUNCTION funk 
END INTERFACE 
END SUBROUTINE midsql 
END INTERFACE 
INTERFACE " 

SUBROUTINE midsqu(funk,aa,bb,s,n) 
USE nrtype 

REAL(SP), INTENT(IN) :: aa,bb 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION funk(x) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: funk 
END FUNCTION funk 
END INTERFACE 
END SUBROUTINE midsqu 
END INTERFACE 
INTERFACE 

RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var) 

USE nrtype 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP) :: func 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
END FUNCTION func 
END INTERFACE 

REAL(SP), DIMENSIONO), INTENT(IN) :: regn 
INTEGER(I4B), INTENT(IN) :: ndim,npts 
REAL(SP), INTENT(IN) :: dith 
REAL(SP), INTENT(OUT) :: ave,var 
END SUBROUTINE miser 
END INTERFACE 
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INTERFACE 

SUBROUTINE mmid(y4yto,xs,htot,nstep,yout,derivs) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: nstep 

REAL(SP), INTENT(IN) :: xs,htot 

REAL(SP), DIMENSION(:), INTENT(IN) :: y.dydx 

REAL(SP), DIMENSION(:), INTENT(OUT) :: yout 

INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(IN) :: y 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE mmid 
END INTERFACE 
INTERFACE 

SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) 

USE nrtype 

REAL(SP), INTENT(INOUT) :: ax,bx 
REAL(SP), INTENT(OUT) : : cx,fa,fb,fc 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE mnbrak 
END INTERFACE 
INTERFACE 

SUBROUTINE rnnewt(ntrial,x,tolx,tolf,usrfun) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: ntrial 
REAL(SP), INTENT(IN) :: tolx,tolf 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: x 
INTERFACE 

SUBROUTINE usrfun(x,fVec,fjac) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: fjac 
END SUBROUTINE usrfun 

END INTERFACE 

END SUBROUTINE mnewt 



[nr.f90] 



END INTERFACE 
INTERFACE 

SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt) 
USE nrtype 

REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt 

REAL(SP), DIMENSIONS, INTENT(IN) :: data 

END SUBROUTINE moment 
END INTERFACE 
INTERFACE 

SUBROUTINE mp2dfr(a,s,n,m) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 

INTEGER(I4B), INTENT(OUT) :: m 

CHARACTER(1 ), DIMENSION(:), INTENT(INOUT) :: a 

CHARACTER(l), DIMENSION(:), INTENT(OUT) :: s 

END SUBROUTINE mp2dfr 
END INTERFACE 
INTERFACE 

SUBROUTINE mpdiv(q,r,u,v,n,m) 

USE nrtype 

CHARACTER(l), DIMENSION(:), INTENT(OUT) :: q,r 

CHARACTER(l), DIMENSION(:), INTENT(IN) :: u,v 

1NTEGER(I4B), INTENT(IN) :: n,m 

END SUBROUTINE mpdiv 
END INTERFACE 
INTERFACE 

SUBROUTINE mpinv(u,v,n,m) 

USE nrtype 

CH ARACTER( 1 ), DIMENSION(:), INTENT(OUT) :: u 

CHARACTER(l), DIMENSIONS, INTENT(IN) :: v 

INTEGER(I4B), INTENT(IN) :: n,m 

END SUBROUTINE mpinv 
END INTERFACE 
INTERFACE 

SUBROUTINE mpmul(w,u,v,n,m) 

USE nrtype 

CHARACTER^), DIMENSION(:), INTENT(IN) :: u,v 

CHARACTER(l), DIMENSION(:), INTENT(OUT) :: w 

INTEGER(I4B), INTENT(IN) :: n,m 

END SUBROUTINE mpmul 
END INTERFACE 
INTERFACE 

SUBROUTINE mppi(n) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
END SUBROUTINE mppi 
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END INTERFACE 
INTERFACE 

SUBROUTINE mprove(a,alud,indx,b,x) 

USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(IN) :: a,alud 

INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx 

REAL(SP), DIMENSIONO), INTENT(IN) :: b 

REAL(SP), DIMENSION(:), INTENT(INOUT) :: x 

END SUBROUTINE mprove 
END INTERFACE 
INTERFACE 

SUBROUTINE mpsqrt(w,u,v,n,m) 

USE nrtype 

CHARACTER(l), DIMENSIONO), INTENT(OUT) :: w,u 

CHARACTER(l), DIMENSIONO), INTENT(IN) :: v 

INTEGER(I4B), INTENT(IN) :: n,m 

END SUBROUTINE mpsqrt 
END INTERFACE 
INTERFACE 

SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,cWsq,funcs) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig 
REAL(SP), DIMENSIONO), INTENT(OUT) :: beta 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: alpha 
REAL(SP), INTENT(OUT) :: chisq 
LOGICAL(LGT), DIMENSIONO), INTENT(IN) :: maska 
INTERFACE • 

SUBROUTINE funcs(x,a,yfit,dyda) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x,a 
REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: dyda 
END SUBROUTINE funcs 
END INTERFACE 
END SUBROUTINE mrqcof 
END INTERFACE 
INTERFACE 

SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y,sig 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a 
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha 
REAL(SP), INTENT(OUT) :: chisq 
REAL(SP), INTENT(INOUT) :: alamda 
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska 
INTERFACE 
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SUBROUTINE funcs(x,a,yfit,dyda) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x,a 
REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit 
REAL(SP), DIMENSIONC,:), INTENT(OUT) :: dyda 
END SUBROUTINE funcs 

END INTERFACE 

END SUBROUTINE mrqmin 
END INTERFACE 
INTERFACE 

SUBROUTINE newt(x,check) 

USE nrtype 

REAL(SP), DIMENSION^, INTENT(INOUT) :: x 

LOGIC AL(LGT), INTENT(OUT) :: check 

END SUBROUTINE newt 
END INTERFACE 
INTERFACE 

SUBROUTINE odeint(ystart,xl ,x2,eps,hl ,hmin,derivs,rkqs) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: ystart 
REAL(SP), INTENT(IN) :: xl,x2,eps,hl,hmin 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONC), INTENT(IN) :: y 
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 

SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: y 
REAL(SP), DIMENSIONC), INTENT(IN) :: dydx,yscal 
REAL(SP), INTENT(INOUT) :: x 
REAL(SP), INTENT(IN) :: htry,eps 
REAL(SP), INTENT(OUT) :: hdid.hnext 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONC), INTENT(IN) :: y 
REAL(SP), DIMENSIONC:), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE rkqs 
END INTERFACE 
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END SUBROUTINE odeint 
END INTERFACE 
INTERFACE 

SUBROUTINE orthog(anu,alpha,beta,a,b) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: anu,alpha,beta 

REAL(SP), DIMENSIONC), INTENT(OUT) :: a,b 

END SUBROUTINE orthog 
END INTERFACE 
INTERFACE 

SUBROUTINE pade(cof,resid) 

USE nrtype 

REAL (DP), DIMENSIONC), INTENT(INOUT) :: cof 

REAL(SP), INTENT(OUT) :: resid 

END SUBROUTINE pade 
END INTERFACE 
INTERFACE 

FUNCTION pccheb(d) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: d 

REAL(SP), DIMENSION(size(d)) :: pccheb 

END FUNCTION pccheb 
END INTERFACE 
INTERFACE 

SUBROUTINE pcshft(a,b,d) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: d 

END SUBROUTINE pcshft 
END INTERFACE 
INTERFACE 

SUBROUTINE pearsn(x,y,r,prob,z) 

USE nrtype 

REAL(SP), INTENT(OUT) :: r,prob,z 
REAL(SP), DIMENSIONC), INTENT(IN) :: x,y 
END SUBROUTINE pearsn 

END INTERFACE 

INTERFACE 

SUBROUTINE period(x,y,ofac,hifac,px,py j max,prob) 
USE nrtype 

INTEGER(I4B), INTENT(OUT) :: jmax 
REAL(SP), INTENT(IN) :: ofac,hifac 
REAL(SP), INTENT(OUT) :: prob 
REAL(SP), DIMENSIONC), INTENT(IN) :: x,y 
REAL(SP), DIMENSIONC), POINTER :: px,py 
END SUBROUTINE period 
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END INTERFACE 
INTERFACE plgndr 

FUNCTION plgndr_s(l,m,x) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: l,m 
REAL(SP), INTENT(IN) :: x 
REAL(SP) :: plgndr_s 
END FUNCTION plgndr_s 

!BL 

FUNCTION plgndr_v(l,m,x) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: l,m 
REAL(SP), DIMENSION(:), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: plgndr_v 
END FUNCTION plgndr_v 

END INTERFACE 

INTERFACE 

FUNCTION poidev(xm) 
USE nrtype 

REAL(SP), INTENT(IN) :: xm 

REAL(SP) :: poidev 

END FUNCTION poidev 
END INTERFACE 
INTERFACE 

FUNCTION polcoe(x,y) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x,y 

REAL(SP), DIMENSION(size(x)) :: polcoe 

END FUNCTION polcoe 
END INTERFACE 
INTERFACE 

FUNCTION poIcof(xa,ya) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: xa,ya 

REAL(SP), DIMENSION(size(xa)) :: polcof 

END FUNCTION polcof 
END INTERFACE 
INTERFACE 

SUBROUTINE poldiv(u,v,q,r) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: u,v 

REAL(SP), DIMENSIONC), INTENT(OUT) :: q,r 

END SUBROUTINE poldiv 
END INTERFACE 
INTERFACE 

SUBROUTINE polin2(x 1 a,x2a,ya,x 1 ,x2,y ,dy) 
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USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: xla,x2a 

REAL(SP), DIMENSIONO,:), INTENT(IN) :: ya 

REAL(SP), INTENT(IN) :: xl,x2 

REAL(SP), INTENT(OUT) :: y,dy 

END SUBROUTINE polin2 
END INTERFACE 
INTERFACE 

SUBROUTINE polint(xa,ya,x,y,dy) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: xa,ya 

REAL(SP), INTENT(IN) :: x 

REAL(SP), INTENT(OUT) :: y,dy 

END SUBROUTINE polint 
END INTERFACE 
INTERFACE 

SUBROUTINE powell(p,xi,ftol,iter,fret) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: p 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: xi 

INTEGER(I4B), INTENT(OUT) :: iter 

REAL(SP), INTENT(IN) :: ftol 

REAL(SP), INTENT(OUT) :: fret 

END SUBROUTINE powell 
END INTERFACE 
INTERFACE 

FUNCTION predic(data,d,nfut) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: data,d 
INTEGER(I4B), INTENT(IN) :: nfut 
REAL(SP), DIMENSION(nfut) :: predic 
END FUNCTION predic 

END INTERFACE 

INTERFACE 

FUNCTION probks(alam) 
USE nrtype 

REAL(SP), INTENT(IN) :: alam 

REAL(SP) :: probks 

END FUNCTION probks 
END INTERFACE 
INTERFACE psdes 

SUBROUTINE psdes_s(lword,rword) 

USE nrtype 

INTEGER(I4B), INTENT(INOUT) :: lword,rword 
END SUBROUTINE psdes_s 

!BL 
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SUBROUTINE psdes_v(lword,rword) 
USE nrtype 

INTEGER(I4B), DIMENSIONO), INTENT(INOUT) :: lword,rword 

END SUBROUTINE psdes_v 
END INTERFACE 
INTERFACE 

SUBROUTINE pwt(a,isign) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: a 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE pwt 
END INTERFACE 
INTERFACE 

SUBROUTINE pwtset(n) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 

END SUBROUTINE pwtset 
END INTERFACE 
INTERFACE pythag 

FUNCTION pythag_sp(a,b) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 

REAL(SP) :: pythag_sp 

END FUNCTION pythag_sp 
• END INTERFACE 
INTERFACE 

SUBROUTINE pzextr(iest,xest,yest,yz,dy) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: iest 

REAL(SP), INTENT(IN) :: xest 

REAL(SP), DIMENSIONO), INTENT(IN) :: yest 

REAL(SP), DIMENSIONO), INTENT(OUT) :: yz,dy 

END SUBROUTINE pzextr 
END INTERFACE 
INTERFACE 

SUBROUTINE qrdcmp(a,c,d,sing) 

USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: a 

REAL(SP), DIMENSIONO), INTENT(OUT) :: c,d 

LOGIC AL(LGT), INTENT(OUT) :: sing 

END SUBROUTINE qrdcmp 
END INTERFACE 
INTERFACE 

FUNCTION qromb(func,a,b) 

USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
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REAL(SP) :: qromb 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION qromb 
END INTERFACE 
INTERFACE 

FUNCTION qromo(func,a,b,choose) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP) :: qromo 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 

REAL(SP), DIMENSION(size(x)) :: func 

END FUNCTION func 
END INTERFACE 
INTERFACE 

SUBROUTINE choose(funk,aa,bb,s,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: aa,bb 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION funk(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: funk 
END FUNCTION funk 
END INTERFACE 
END SUBROUTINE choose 
END INTERFACE 
END FUNCTION qromo 
END INTERFACE 
INTERFACE 

SUBROUTINE qroot(p,b,c,eps) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: p 
REAL(SP), INTENT(INOUT) :: b,c 
REAL(SP), INTENT(IN) :: eps 
END SUBROUTINE qroot 
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END INTERFACE 
INTERFACE 

SUBROUTINE qrsolv(a,c,d,b) 

USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(IN) :: a 
REAL(SP), DIMENSIONO), INTENT(IN) :: c,d 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: b 
END SUBROUTINE qrsolv 

END INTERFACE 

INTERFACE 

SUBROUTINE qrupdt(r,qt,u,v) 
USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: r,qt 
REAL(SP), DIMENSIONO), INTENT(INOUT) :: u 
REAL(SP), DIMENSIONO), INTENT(IN) :: v 
END SUBROUTINE qrupdt 

END INTERFACE 

INTERFACE 

FUNCTION qsimp(func,a,b) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP) :: qsimp 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION qsimp 
END INTERFACE 
INTERFACE 

FUNCTION qtrap(func,a,b) 
USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP) :: qtrap 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION qtrap 
END INTERFACE 
INTERFACE 
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SUBROUTIN^uadct(x,y,xx,yy,fa,fb,fc,fd) 
USE nrtype 

REAL(SP), INTENT(IN) :: x,y 

REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy 

REAL(SP), INTENT(OUT) :: fa,fb,fc,fd 

END SUBROUTINE quadct 
END INTERFACE 
INTERFACE 

SUBROUTINE quadmx(a) 

USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(OUT) :: a 

END SUBROUTINE quadmx 
END INTERFACE 
INTERFACE 

. SUBROUTINE quadvl(x,y,fa,fb,fc,fd) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,y 

REAL(SP), INTENT(OUT) :: fa,fb,fc,fd 

END SUBROUTINE quadvl 
END INTERFACE 
INTERFACE 

FUNCTION ran(idum) 

INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum 

REAL :: ran 

END FUNCTION ran 
END INTERFACE 
INTERFACE ranO 

SUBROUTINE ranO_s(harvest) 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE ranO_s 

!BL 

SUBROUTINE ranO_v(harvest) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(OUT) :: harvest 

END SUBROUTINE ranO_v 
END INTERFACE 
INTERFACE rani 

SUBROUTINE ranl_s(harvest) 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE ranl_s 

!BL 

SUBROUTINE ranl_v(harvest) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(OUT) :: harvest 
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END SUBROUTINE ranl_v 
END INTERFACE 
INTERFACE ran2 

SUBROUTINE ran2_s(harvest) 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE ran2_s 

!BL 

SUBROUTINE ran2_v(harvest) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest 

END SUBROUTINE ran2_v 
END INTERFACE 
INTERFACE ran3 

SUBROUTINE ran3_s(harvest) 

USE nrtype 

REAL(SP), INTENT(OUT) :: harvest 
END SUBROUTINE ran3_s 

!BL 

SUBROUTINE ran3_v(harvest) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest 

END SUBROUTINE ran3_v 
END INTERFACE 
INTERFACE 

SUBROUTINE ratint(xa,ya,x,y,dy) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya 

REAL(SP), INTENT(IN) :: x 

REAL(SP), INTENT(OUT) :: y,dy 

END SUBROUTINE ratint 
END INTERFACE 
INTERFACE 

SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev) 

USE nrtype 

REAL(DP), INTENT(IN) :: a,b 
INTEGER(I4B), INTENT(IN) :: mm,kk 
REAL(DP), DIMENSION(:), INTENT(OUT) :: cof 
REAL(DP), INTENT(OUT) :: dev 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(DP), DIMENSION(:), INTENT(IN) :: x 
REAL (DP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
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END SUBROUTINE ratlsq 
END INTERFACE 
INTERFACE ratval 

FUNCTION ratval_s(x,cof,mm,kk) 

USE nrtype 

REAL(DP), INTENT(IN) :: x 

INTEGER(I4B), INTENT(IN) :: mm,kk 

REAL(DP), DIMENSION(mm+kk+l), INTENT(IN) :: cof 

REAL(DP) :: ratval_s 

END FUNCTION ratval_s 

FUNCTION ratval_v(x,cof,mm,kk) 
USE nrtype 

REAL(DP), DIMENSIONO), INTENT(IN) :: x 

INTEGER(I4B), INTENT(IN) :: mm,kk 

REAL(DP), DIMENSION(mm+kk+ 1 ), INTENT(IN) :: cof 

REAL (DP), DIMENSION(size(x)) :: ratval_v 

END FUNCTION ratval_v 
END INTERFACE 
INTERFACE rc 

FUNCTION rc_s(x,y) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,y 
REAL(SP) :: rc_s 
END FUNCTION rc_s 

FUNCTION rc_v(x,y) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y 

REAL(SP), DIMENSION(size(x)) :: rc_v 

END FUNCTION rc_v 
END INTERFACE 
INTERFACE rd 

FUNCTION rd_s(x,y,z) 

USE nrtype 

REAL(SP), INTENT(IN) : : x,y,z 
REAL(SP) :: rd_s 
END FUNCTION rd_s 

FUNCTION rd_v(x,y,z) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y,z 

REAL(SP), DIMENSION(size(x)) :: rd_v 

END FUNCTION rd_v 
END INTERFACE 
INTERFACE realft 
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SUBROUTINE realft_sp(data,isign,zdata) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: data 
INTEGER(I4B), INTENT(IN) :: isign 

COMPLEX(SPC), DIMENSION(:) 5 OPTIONAL, TARGET :: zdata 

END SUBROUTINE realftjsp 
END INTERFACE 
INTERFACE 

RECURSIVE FUNCTION recur l(a,b) RESULT(u) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: a,b 

REAL(SP), DIMENSION(size(a)) :: u 

END FUNCTION recurl 
END INTERFACE 
INTERFACE 

FUNCTION recur2(a,b,c) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: a,b,c 

REAL(SP), DIMENSION(size(a)) :: recur2 

END FUNCTION recur2 
END INTERFACE 
INTERFACE 

SUBROUTINE relax(u,rhs) 

USE nrtype 

REAL(DP), DIMENSIONO,:), INTENT(INOUT) :: u 

REAL (DP), DIMENSIONO,:), INTENT(IN) :: rhs 

END SUBROUTINE relax 
END INTERFACE 
INTERFACE 

SUBROUTINE relax2(u,rhs) 

USE nrtype 

REAL(DP), DIMENSIONO,:), INTENT(INOUT) :: u 

REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs 

END SUBROUTINE relax2 
END INTERFACE 
INTERFACE 
FUNCTION resid(u,rhs) 

USE nrtype 

REAL (DP), DIMENSIONO,:), INTENT(IN) :: u,rhs 

REAL(DP), DIMENSION(size(u,l),size(u,l)) :: resid 

END FUNCTION resid 
END INTERFACE 
INTERFACE rf 

FUNCTION rf_s(x,y,z) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,y,z 
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REAL(SP) :: rf_s 
END FUNCTION rf_s 

!BL 

FUNCTION rf_v(x,y,z) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z 

REAL(SP), DIMENSION(size(x)) :: rf_v 

END FUNCTION rf_v 
END INTERFACE 
INTERFACE rj 

FUNCTION rj_s(x,y,z,p) 

USE nrtype 

REAL(SP), INTENT(IN) :: x,y,z,p 
REAL(SP) :: rj_s 
END FUNCTION rj_s 

!BL 

FUNCTION rj_v(x,y,z,p) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: x,y,z,p 

REAL(SP), DIMENSION(size(x)) :: rj_v 

END FUNCTION rj_v 
END INTERFACE 
INTERFACE 

SUBROUTINE rk4(y,dydx,x,h,yout,derivs) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: y,dydx 

REAL(SP), INTENT(IN) :: x,h 

REAL(SP), DIMENSION(:), INTENT(OUT) :: yout 

INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(IN) :: y 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 

END INTERFACE 

END SUBROUTINE rk4 
END INTERFACE 
INTERFACE 

SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) 

USE nrtype 

REAL(SP), DIMENSIONO, INTENT(IN) :: y,dydx 
REAL(SP), INTENT(IN) :: x,h 

REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 



[nr.f90] 



USE nrtype 

REAL(SP), INTENT(IN) : : x 
REAL(SP), DIMENSIONC), INTENT(IN) :: y 
REAL(SP), DIMENSIONC), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 

END INTERFACE 

END SUBROUTINE rkck 
END INTERFACE 
INTERFACE 

SUBROUTINE rkdumb(vstart,xl ,x2,nstep,derivs) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: vstart 
REAL(SP), INTENT(IN) :: xl,x2 
INTEGER(I4B), INTENT(IN) :: nstep 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(IN) :: y 
REAL(SP), DIMENSIONC), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE rkdumb 
END INTERFACE 
INTERFACE 

SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: y 
REAL(SP), DIMENSIONC), INTENT(IN) :: dydx,yscal 
REAL(SP), INTENT(INOUT) :: x 
REAL(SP), INTENT(IN) :: htry,eps 
REAL(SP), INTENT(OUT) :: hdid,hnext 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(IN) :: y 
REAL(SP), DIMENSIONC), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 

END INTERFACE 

END SUBROUTINE rkqs 
END INTERFACE 
INTERFACE 

SUBROUTINE rlft2(data,spec,speq,isign) 

USE nrtype 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data 
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COMPLEX(SPC), DIMENSIONC,:), INTENT(OUT) :: spec 

COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE rlft2 
END INTERFACE 
INTERFACE 

SUBROUTINE rlft3 (data,spec,speq,isign) 

USE nrtype 

REAL(SP), DIMENSIONC,:,:), INTENT(INOUT) :: data 

COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec 

COMPLEX"(SPC), DIMENSION(:,:), INTENT(OUT) :: speq 

INTEGER(I4B), INTENT(IN) :: isign 

END SUBROUTINE rlft3 
END INTERFACE 
INTERFACE 

SUBROUTINE rotate(r,qt,i,a,b) 

USE nrtype 

REAL(SP), DIMENSIONC,:), TARGET, INTENT(INOUT) :: r,qt 

INTEGER(I4B), INTENT(IN) :: i 

REAL(SP), INTENT(IN) :: a,b 

END SUBROUTINE rotate 
END INTERFACE 
INTERFACE 

SUBROUTINE rsolv(a,d,b) 

USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: a 

REAL(SP), DIMENSIONC), INTENT(IN) :: d 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: b 

END SUBROUTINE rsolv 
END INTERFACE 
INTERFACE 

FUNCTION rstrct(uf) 

USE nrtype 

REAL(DP), DIMENSIONC,:), INTENT(IN) :: uf 

REAL(DP), DIMENSION((size(uf,l)+l)/2,(size(uf,l)+l)/2) :: rstrct 

END FUNCTION rstrct 
END INTERFACE 
INTERFACE 

FUNCTION rtbis(func,xl,x2,xacc) 

USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: rtbis 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
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REAL(SP) :: fiinc 
END FUNCTION func 
END INTERFACE 
END FUNCTION rtbis 
END INTERFACE 
INTERFACE 

FUNCTION rtflsp(func,xl,x2,xacc) 
USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: rtflsp 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION rtflsp 
END INTERFACE 
INTERFACE 

FUNCTION rtnewt(funcd,xl,x2,xacc) 
USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: rtnewt 

INTERFACE 

SUBROUTINE funcd(x,fVal,fderiv) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), INTENT(OUT) :: fval,fderiv 
END SUBROUTINE funcd 
END INTERFACE 
END FUNCTION rtnewt 
END INTERFACE 
INTERFACE 

FUNCTION rtsafe(funcd,xl,x2,xacc) 
USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: rtsafe 

INTERFACE 

SUBROUTINE funcd(x,fval,fderiv) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), INTENT(OUT) :: fval,fderiv 
END SUBROUTINE funcd 

END INTERFACE 

END FUNCTION rtsafe 
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END INTERFACE 
INTERFACE 

FUNCTION rtsec(func,xl,x2,xacc) 

USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: Usee 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION rtsec 
END INTERFACE 
INTERFACE 

SUBROUTINE rzextr(iest,xest,yest,yz,dy) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: iest 

REAL(SP), INTENT(IN) :: xest 

REAL(SP), DIMENSIONO), INTENT(IN) :: yest 

REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy 

END SUBROUTINE rzextr 
END INTERFACE 
INTERFACE 

FUNCTION savgol(nl,nrr,ld,m) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m 

REAL(SP), DIMENSION(nl+nrr+l) :: savgol 

END FUNCTION savgol 
END INTERFACE 
INTERFACE 

SUBROUTINE scrsho(func) 

USE nrtype 

INTERFACE 

FUNCTION func(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE scrsho 
END INTERFACE 
INTERFACE 

FUNCTION select(k,arr) 
USE nrtype 
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INTEGER(I4B), INTENT(IN) :: k 

REAL(SP), DIMENSIONO, INTENT(INOUT) :: arr 

REAL(SP) :: select 

END FUNCTION select 
END INTERFACE 
INTERFACE 

FUNCTION select_bypack(k,arr) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: k 

REAL(SP), DIMENSIONO, INTENT(INOUT) :: arr 

REAL(SP) :: select_bypack 

END FUNCTION select_bypack 
END INTERFACE 
INTERFACE 

SUBROUTINE select_heap(arr,heap) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: arr 

REAL(SP), DIMENSIONO, INTENT(OUT) :: heap 

END SUBROUTINE selectjieap 
END INTERFACE 
INTERFACE 

FUNCTION select_inplace(k,arr) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: k 

REAL(SP), DIMENSION(:), INTENT(IN) :: arr 

REAL(SP) :: select_inplace 

END FUNCTION select_inplace 
END INTERFACE 
INTERFACE 

SUBROUTINE simplx(a,m 1 ,m2,m3,icase,izrov,iposv) 
USE nrtype 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a 

INTEGER(I4B), INTENT(IN) :: ml,m2,m3 

INTEGER(I4B), INTENT(OUT) :: icase 

INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv 

END SUBROUTINE simplx 
END INTERFACE 
INTERFACE 

SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs) 
USE nrtype 

REAL(SP), INTENT(IN) :: xs,htot 

REAL(SP), DIMENSIONO, INTENT(IN) :: y,dydx,dfdx 

REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy 

INTEGER(I4B), INTENT(IN) :: nstep 

REAL(SP), DIMENSIONO, INTENT(OUT) :: yout 

INTERFACE 



SUBROUTINE derivs(x,y,dydx) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(IN) :: y 
REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 

END INTERFACE 

END SUBROUTINE simpr 
END INTERFACE 
INTERFACE 

SUBROUTINE sinft(y) 

USE nrtype 

REAL(SP), DIMENSIONS, INTENT(INOUT) :: y 

END SUBROUTINE sinft 
END INTERFACE 
INTERFACE 

SUBROUTINE slvsm2(u,rhs) 

USE nrtype 

REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u 

REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs 

END SUBROUTINE slvsm2 
END INTERFACE 
INTERFACE 

SUBROUTINE slvsml(u,rhs) 

USE nrtype 

REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u 

REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs 

END SUBROUTINE slvsml 
END INTERFACE 
INTERFACE 

SUBROUTINE sncndn(uu,emmc,sn,cn,dn) 

USE nrtype 

REAL(SP), INTENT(IN) :: uu,emmc 

REAL(SP), INTENT(OUT) :: sn,cn,dn 

END SUBROUTINE sncndn 
END INTERFACE 
INTERFACE 

FUNCTION snrm(sx,itol) 

USE nrtype 

REAL(DP), DIMENSIONO), INTENT(IN) :: sx 

INTEGER(I4B), INTENT(IN) :: itol 

REAL(DP) :: snrm 

END FUNCTION snrm 
END INTERFACE 
INTERFACE 

SUBROUTINE sobseq(x,init) 
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USE nrtype 

REAL(SP), DIMENSIONC), INTENT(OUT) :: x 
INTEGER(I4B), OPTIONAL, INTENT(IN) :: ink 
END SUBROUTINE sobseq 

END INTERFACE 

INTERFACE 

SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: itmax,nb 
REAL(SP), INTENT(IN) :: conv,slowc 
REAL(SP), DIMENSIONC), INTENT(IN) :: scalv 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv 
REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: y 
END SUBROUTINE solvde 

END INTERFACE 

INTERFACE 

SUBROUTINE sor(a,b,c,d,e,f,u,rjac) 
USE nrtype 

REAL (DP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f 

REAL (DP), DIMENSIONC,:), INTENT(INOUT) :: u 

REAL (DP), INTENT(IN) :: rjac 

END SUBROUTINE sor 
END INTERFACE 
INTERFACE 

SUBROUTINE sort(arr) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: arr 

END SUBROUTINE sort 
END INTERFACE 
INTERFACE 

SUBROUTINE sort2 (arr, slave) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: arr,slave 

END SUBROUTINE sort2 
END INTERFACE 
INTERFACE 

SUBROUTINE sort3(arr,slavel,slave2) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: arr,slavel,slave2 

END SUBROUTINE sort3 
END INTERFACE 
INTERFACE 

SUBROUTINE sort_bypack(arr) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr 
END SUBROUTINE sort_bypack 
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END INTERFACE 
INTERFACE 

SUBROUTINE sort_byreshape(arr) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: arr 

END SUBROUTINE sort_byreshape 
END INTERFACE 
INTERFACE 

SUBROUTINE sortjieap(arr) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: arr 

END SUBROUTINE sortjieap 
END INTERFACE 
INTERFACE 

SUBROUTINE sort_pick(arr) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: arr 

END SUBROUTINE sort_pick 
END INTERFACE 
INTERFACE 

SUBROUTINE sort_radix(arr) 

USE nrtype 

REAL(SP), DIMENSIONO, INTENT(INOUT) :: arr 

END SUBROUTINE sort_radix 
END INTERFACE 
INTERFACE 

SUBROUTINE sort_shell(arr) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: arr 

END SUBROUTINE sort_shell 
END INTERFACE 
INTERFACE 

SUBROUTINE spctrm(p,k,ovrlap,unit,n_window) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(OUT) :: p 

INTEGER(I4B), INTENT(IN) :: k 

LOGIC AL(LGT), INTENT(IN) :: ovrlap 

INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit 

END SUBROUTINE spctrm 
END INTERFACE 
INTERFACE 

SUBROUTINE spear(datal ,data2,d,zd,probd,rs,probrs) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: datal,data2 
REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs 
END SUBROUTINE spear 
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END INTERFACE 
INTERFACE sphbes 

SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp) 

USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), INTENT(IN) :: x 
REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp 
END SUBROUTINE sphbes_s 

!BL 

SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSIONS, INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp 
END SUBROUTINE sphbes_v 

END INTERFACE 

INTERFACE 

SUBROUTINE splie2(xla,x2a,ya,y2a) 
USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: xla,x2a 
REAL(SP), DIMENSIONS:), INTENT(IN) :: ya 
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a 
END SUBROUTINE splie2 

END INTERFACE 

INTERFACE 

FUNCTION splin2(x 1 a,x2a,ya,y2a,x 1 ,x2) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: xla,x2a 

REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a 

REAL(SP), INTENT(IN) :: xl,x2 

REAL(SP) :: splin2 

END FUNCTION splin2 
END INTERFACE 
INTERFACE 

SUBROUTINE spline(x,y,ypl ,ypn,y2) 

USE nrtype 

REAL(SP), DIMENSIONS, INTENT(IN) :: x,y 

REAL(SP), INTENT(IN) :: ypl,ypn 

REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 

END SUBROUTINE spline 
END INTERFACE 
INTERFACE 

FUNCTION splint(xa,ya,y2a,x) 

USE nrtype 

REAL(SP), DIMENSION!:), INTENT(IN) :: xa,ya,y2a 
REAL(SP), INTENT(IN) :: x 
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REAL(SP) :: splint 

END FUNCTION splint 
END INTERFACE 
INTERFACE sprsax 

SUBROUTINE sprsax_dp(sa,x,b) 

USE nrtype 

TYPE(sprs2_dp), INTENT(IN) :: sa 
REAL(DP), DIMENSION (:), INTENT(IN) :: x 
REAL(DP), DIMENSION (:), INTENT(OUT) :: b 
END SUBROUTINE sprsax_dp 

!BL 

SUBROUTINE sprsax_sp(sa,x,b) 
USE nrtype 

TYPE(sprs2_sp), INTENT(IN) :: sa 
REAL(SP), DIMENSION (:), INTENT(IN) :: x 
REAL(SP), DIMENSION (:), INTENT(OUT) :: b 
END SUBROUTINE sprsax_sp 

END INTERFACE 

INTERFACE sprsdiag 

SUBROUTINE sprsdiag_dp(sa,b) 
USE nrtype 

TYPE(sprs2_dp), INTENT(IN) :: sa 

REAL (DP), DIMENSIONO), INTENT(OUT) :: b 

END SUBROUTINE sprsdiag_dp 

!BL 

SUBROUTINE sprsdiag_sp(sa,b) 
USE nrtype 

TYPE(sprs2_sp), INTENT(IN) :: sa 
REAL(SP), DIMENSIONO, INTENT(OUT) :: b 
END SUBROUTINE sprsdiag_sp 

END INTERFACE 

INTERFACE sprsin 

SUBROUTINE sprsin_sp(a,thresh,sa) 
USE nrtype 

REAL(SP), DIMENSION(:,:), INTENT(IN) :: a 
REAL(SP), INTENT(IN) :: thresh 
TYPE(sprs2_sp), INTENT(OUT) :: sa 
END SUBROUTINE sprsin_sp 

!BL 

SUBROUTINE sprsin_dp(a,thresh,sa) 
USE nrtype 

REAL (DP), DIMENSIONO,:), INTENT(IN) :: a 
REAL (DP), INTENT(IN) :: thresh 
TYPE(sprs2_dp), INTENT(OUT) :: sa 
END SUBROUTINE sprsin_dp 
END INTERFACE 
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INTERFACE 

SUBROUTINE sprstp(sa) 
USE nrtype 

TYPE(sprs2_sp), INTENT(INOUT) :: sa 

END SUBROUTINE sprstp 
END INTERFACE 
INTERFACE sprstx 

SUBROUTINE sprstx_dp(sa,x,b) 

USE nrtype 

TYPE(sprs2_dp), INTENT(IN) :: sa 
REAL(DP), DIMENSION (:), INTENT(IN) :: x 
REAL(DP), DIMENSION (:), INTENT(OUT) :: b 
END SUBROUTINE sprstx_dp 

!BL 

SUBROUTINE sprstx_sp(sa,x,b) 
USE nrtype 

TYPE(sprs2_sp), INTENT(IN) :: sa 
REAL(SP), DIMENSION (:), INTENT(IN) :: x 
REAL(SP), DIMENSION (:), INTENT(OUT) :: b 
END SUBROUTINE sprstx_sp 

END INTERFACE 

INTERFACE 

SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: y 
REAL(SP), DIMENSIONO), INTENT(IN) :: dydx,yscal 
REAL(SP), INTENT(IN) :: htry,eps 
REAL(SP), INTENT(INOUT) :: x 
REAL(SP), INTENT(OUT) :: hdid,hnext 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(IN) :: y 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE stifbs 
END INTERFACE 
INTERFACE 

SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: y 
REAL(SP), DIMENSIONO), INTENT(IN) :: dydx,yscal 
REAL(SP), INTENT(INOUT) :: x 
REAL(SP), INTENT(IN) :: htry,eps 
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REAL(SP), INTENT(OUT) :: hdid,hnext 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP), DIMENSION(:), INTENT(IN) :: y 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 
END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE stiff 
END INTERFACE 
INTERFACE 

SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs) 
USE nrtype 

REAL(SP), DIMENSION^:), INTENT(IN) :: y,d2y 
REAL(SP), INTENT(IN) :: xs,htot 
INTEGER(I4B), INTENT(IN) :: nstep 
REAL(SP), DIMENSIONO), INTENT(OUT) :: yout 
INTERFACE 

SUBROUTINE derivs(x,y,dydx) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 

REAL(SP), DIMENSIONO), INTENT(IN) :: y 

REAL(SP), DIMENSIONO), INTENT(OUT) :: dydx 

END SUBROUTINE derivs 
END INTERFACE 
END SUBROUTINE stoerm 
END INTERFACE 
INTERFACE svbksb 

SUBROUTINE svbksb_sp(u,w,v,b,x) 
USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(IN) :: u,v 
REAL(SP), DIMENSIONO), INTENT(IN) :: w,b 
REAL(SP), DIMENSIONO), INTENT(OUT) :: x 
END SUBROUTINE svbksb_sp 

END INTERFACE 

INTERFACE svdcmp 

SUBROUTINE svdcmp_sp(a,w,v) 
USE nrtype 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: a 
REAL(SP), DIMENSIONO), INTENT(OUT) :: w 
REAL(SP), DIMENSIONO,:), INTENT(OUT) :: v 
END SUBROUTINE svdcmp_sp 

END INTERFACE 

INTERFACE 

SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs) 
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USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x,y,sig 
REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w 
REAL(SP), DIMENSIONC,:), INTENT(OUT) :: v 
REAL(SP), INTENT(OUT) :: chisq 
INTERFACE 

FUNCTION funcs(x,n) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP), DIMENSION(n) :: funcs 

END FUNCTION funcs 
END INTERFACE 
END SUBROUTINE svdfit 
END INTERFACE 
INTERFACE 

SUBROUTINE svdvar(v,w,cvm) 
USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(IN) :: v 
REAL(SP), DIMENSION(:), INTENT(IN) :: w 
REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm 
END SUBROUTINE svdvar 

END INTERFACE 

INTERFACE 

FUNCTION toeplz(r,y) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: r,y 

REAL(SP), DIMENSION(size(y)) :: toeplz 

END FUNCTION toeplz 
END INTERFACE 
INTERFACE 

SUBROUTINE tptest(datal ,data2,t,prob) 

USE nrtype 

REAL(SP), DIMENSION(:), INTENT(IN) :: datal,data2 

REAL(SP), INTENT(OUT) :: t,prob 

END SUBROUTINE tptest 
END INTERFACE 
INTERFACE 

SUBROUTINE tqli(d,e,z) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: d,e 

REAL(SP), DIMENSIONC,:), OPTIONAL, INTENT(INOUT) :: z 

END SUBROUTINE tqli 
END INTERFACE 
INTERFACE 

SUBROUTINE trapzd(func,a,b,s,n) 
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USE nrtype 

REAL(SP), INTENT(IN) :: a,b 
REAL(SP), INTENT(INOUT) :: s 
INTEGER(I4B), INTENT(IN) :: n 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: x 
REAL(SP), DIMENSION(size(x)) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE trapzd 
END INTERFACE 
INTERFACE 

SUBROUTINE tred2(a,d,e,novectors) 
USE nrtype 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 
REAL(SP), DIMENSIONC), INTENT(OUT) :: d,e 
LOGIC AL(LGT), OPTIONAL, INTENT(IN) :: novectors 
END SUBROUTINE tred2 
END INTERFACE 
! On a purely serial machine, for greater efficiency, remove 
! the generic name tridag from the following interface, 
! and put it on the next one after that. 
INTERFACE tridag 

RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: a,b,c,r 

REAL(SP), DIMENSIONC), INTENT(OUT) :: u 

END SUBROUTINE tridag_par 
END INTERFACE 
INTERFACE 

SUBROUTINE tridag_ser(a,b,c,r,u) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: a,b,c,r 

REAL(SP), DIMENSIONC), INTENT(OUT) :: u 

END SUBROUTINE tridag_ser 
END INTERFACE 
INTERFACE 

SUBROUTINE ttest(data 1 ,data2,t,prob) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: datal,data2 

REAL(SP), INTENT(OUT) :: t,prob 

END SUBROUTINE ttest 
END INTERFACE 
INTERFACE 
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SUBROUTINE tutest(datal ,data2,t,prob) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: datal,data2 

REAL(SP), INTENT(OUT) :: t,prob 

END SUBROUTINE tutest 
END INTERFACE 
INTERFACE 

SUBROUTINE twofft(datal,data2,fftl,fft2) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: datal,data2 

COMPLEX(SPC), DIMENSIONO), INTENT(OUT) :: fftl,fft2 

END SUBROUTINE twofft 
END INTERFACE 
INTERFACE 

FUNCTION vander(x,q) 

USE nrtype 

REAL(DP), DIMENSIONO), INTENT(IN) :: x,q 

REAL (DP), DIMENSION(size(x)) :: vander 

END FUNCTION vander 
END INTERFACE 
INTERFACE 

SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a) 
USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: region 
INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn 
REAL(SP), INTENT(OUT) :: tgral,sd,chi2a 
INTERFACE 

FUNCTION func(pt,wgt) 

USE nrtype 

REAL(SP), DIMENSIONO), INTENT(IN) :: pt 

REAL(SP), INTENT(IN) :: wgt 

REAL(SP) :: func 

END FUNCTION func 
END INTERFACE 
END SUBROUTINE vegas 
END INTERFACE 
INTERFACE 

SUBROUTINE voltra(tO,h,t,f,g,ak) 
USE nrtype 

REAL(SP), INTENT(IN) :: tO,h 

REAL(SP), DIMENSIONO), INTENT(OUT) :: t 

REAL(SP), DIMENSIONO,:), INTENT(OUT) :: f 

INTERFACE 

FUNCTION g(t) 

USE nrtype 

REAL(SP), INTENT(IN) :: t 
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REAL(SP), DIMENSIONC), POINTER :: g 
END FUNCTION g 

!BL 

FUNCTION ak(t,s) 
USE nrtype 

REAL(SP), INTENT(IN) :: t,s 
REAL(SP), DIMENSIONC,:), POINTER :: ak 
END FUNCTION ak 
END INTERFACE 
END SUBROUTINE voltra 
END INTERFACE 
INTERFACE 

SUBROUTINE wtl(a,isign,wtstep) 
USE nrtype 

REAL(SP), DIMENSION(:), INTENT(INOUT) : : a 
INTEGER(I4B), INTENT(IN) :: isign 
INTERFACE 

SUBROUTINE wtstep(a,isign) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) : : a 
INTEGER(I4B), INTENT(IN) :: isign 
END SUBROUTINE wtstep 
END INTERFACE 
END SUBROUTINE wtl 
END INTERFACE 
INTERFACE 

SUBROUTINE wtn(a,nn,isign,wtstep) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: a 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn 
INTEGER(I4B), INTENT(IN) :: isign 
INTERFACE 

SUBROUTINE wtstep(a,isign) 

USE nrtype 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: a 
INTEGER(I4B), INTENT(IN) :: isign 
END SUBROUTINE wtstep 
END INTERFACE 
END SUBROUTINE wtn 
END INTERFACE 
INTERFACE 

FUNCTION wwghts(n,h,kermom) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), INTENT(IN) :: h 
REAL(SP), DIMENSION(n) :: wwghts 
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INTERFACE 

FUNCTION kermom(y,m) 
USE nrtype 

REAL(DP), INTENT(IN) :: y 
INTEGER(I4B), INTENT(IN) :: m 
REAL(DP), DIMENSION(m) :: kermom 
END FUNCTION kermom 

END INTERFACE 

END FUNCTION wwghts 
END INTERFACE 
INTERFACE 

SUBROUTINE zbrac(func,xl,x2,succes) 

USE nrtype 

REAL(SP), INTENT(INOUT) :: xl,x2 
LOGIC AL(LGT), INTENT(OUT) :: succes 
INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE zbrac 
END INTERFACE 
INTERFACE 

SUBROUTINE zbrak(func,x 1 ,x2,n,xb 1 ,xb2,nb) 
USE nrtype 

INTEGER(I4B), INTENT(IN) :: n 

INTEGER(I4B), INTENT(OUT) :: nb 

REAL(SP), INTENT(IN) :: xl,x2 

REAL(SP), DIMENSION(:), POINTER :: xbl,xb2 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END SUBROUTINE zbrak 
END INTERFACE 
INTERFACE 

FUNCTION zbrent(func,xl,x2,tol) 
USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,tol 
REAL(SP) :: zbrent 
INTERFACE 
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FUNCTION fiinc(x) 
USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: func 
END FUNCTION func 
END INTERFACE 
END FUNCTION zbrent 
END INTERFACE 
INTERFACE 

SUBROUTINE zrhqr(a,rtr,rti) 
USE nrtype 

REAL(SP), DIMENSIONC), INTENT(IN) :: a 

REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti 

END SUBROUTINE zrhqr 
END INTERFACE 
INTERFACE 

FUNCTION zriddr(tunc,xl,x2,xacc) 

USE nrtype 

REAL(SP), INTENT(IN) :: xl,x2,xacc 

REAL(SP) :: zriddr 

INTERFACE 

FUNCTION func(x) 

USE nrtype 

REAL(SP), INTENT(IN) :: x 
REAL(SP) :: tunc 
END FUNCTION tunc 
END INTERFACE 
END FUNCTION zriddr 
END INTERFACE 
INTERFACE 

SUBROUTINE zroots(a,roots,poIish) 
USE nrtype 

COMPLEX(SPC), DIMENSIONC), INTENT(IN) :: a 
COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots 
LOGIC AL(LGT), INTENT(IN) :: polish 
END SUBROUTINE zroots 
END INTERFACE 
END MODULE nr 
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MODULE nrtype 

INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) 
INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) 
INTEGER, PARAMETER :: I IB = SELECTED_INT_KIND(2) 
INTEGER, PARAMETER :: SP = KIND(l.ODO) 
INTEGER, PARAMETER :: DP = KIND(l.ODO) 
INTEGER, PARAMETER :: SPC = KIND((1.0DO,1.0DO)) 
INTEGER, PARAMETER :: DPC = KIND((1.0DO,1.0DO)) 
INTEGER, PARAMETER :: LGT = KIND(.true.) 

REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp 
REAL(SP), PARAMETER : : PI02=1 .57079632679489661 923 1 32 1 691 63975 144209858_sp 
REAL(SP), PARAMETER :: TWOPI=6.283 1 853071 795864769252867665 590057683 94_sp 
REAL(SP), PARAMETER :: 

SQRT2=1.41421356237309504880168872420969807856967_sp 

REAL(SP), PAR AMETER :: 

EULER=0.5772 1566490 153286060651 209008240243 10422_sp 

REAL(DP),PARAMETER::PI_D=3.141592653589793238462643383279502884197_dp 
REAL(DP), PARAMETER :: 

PI02_D= 1 .5707963267948966 1 923 1 32 1 69 1 63 975 1 4420985 8_dp 

REAL(DP), PARAMETER :: 

TWOPI_D=6.2831 85307 179586476925286766559005768394_dp 
TYPE sprs2_sp 

INTEGER(I4B) :: n,len 

REAL(SP), DIMENSIONC), POINTER :: val 

INTEGER(I4B), DIMENSION(:), POINTER :: irow 

INTEGER(I4B), DIMENSION(:), POINTER :: jcol 
END TYPE sprs2_sp 
TYPE sprs2_dp 

INTEGER(I4B) :: n,len 

REAL(DP), DIMENSION(:), POINTER :: val 

INTEGER(I4B), DIMENSION(:), POINTER :: irow 

INTEGER(I4B), DIMENSION(:), POINTER :: jcol 
END TYPE sprs2_dp 
END MODULE nrtype 
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MODULE nrutil 

USE nrtype 
IMPLICIT NONE 

INTEGER(I4B), PARAMETER :: NP AR_ARTH= 1 6,NP AR2_ARTH=8 
INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 
INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 
INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 
INTEGER(I4B), PARAMETER :: NPAR_POLY=8 
INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 
INTERFACE arraycopy 

MODULE PROCEDURE array_copy_r, array copy i 
END INTERFACE 
INTERFACE swap 

MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & 
swap_cv,swap_cm, & 

masked_swap_rs,masked_swap_rv,masked_swap_rm 
END INTERFACE 
INTERFACE reallocate 

MODULE PROCEDURE reallocate_rv,reallocate_rm,& 
reallocate_iv,reallocate_im,reallocate_hv 
END INTERFACE 
INTERFACE imaxloc 

MODULE PROCEDURE imaxloc_r,imaxloc_i 
END INTERFACE 
INTERFACE assert 

MODULE PROCEDURE assertl,assert2,assert3,assert4,assert_v 
END INTERFACE 
INTERFACE assert_eq 

MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn 
END INTERFACE 
INTERFACE arth 

MODULE PROCEDURE arth_r, arth_i 
END INTERFACE 
INTERFACE geop 

MODULE PROCEDURE geop r, geop i, geop c, geop dv 
END INTERFACE 
INTERFACE cumsum 

MODULE PROCEDURE cumsum_r,cumsum_i 
END INTERFACE 
INTERFACE poly 

MODULE PROCEDURE poly_rr,poly_rrv,& 
poly_rc,poly_cc,poly_msk_rrv 
END INTERFACE 
INTERFACE polyjerm 

MODULE PROCEDURE poly_term_rr,poly_term_cc 
END INTERFACE 
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INTERFACE outerprod 

MODULE PROCEDURE outerprod_r 
END INTERFACE 
INTERFACE outerdiff 

MODULE PROCEDURE outerdiff_r,outerdiff_i 
END INTERFACE 
INTERFACE scatter_add 

MODULE PROCEDURE scatter_add_r 
END INTERFACE 
INTERFACE scatterjnax 

MODULE PROCEDURE scattermaxr 
END INTERFACE 
INTERFACE diagadd 

MODULE PROCEDURE diagadd_rv,diagadd_r 

END INTERFACE 
INTERFACE diagmult 

MODULE PROCEDURE diagrnult_rv,diagmult_r 
END INTERFACE 
INTERFACE get_diag 

MODULE PROCEDURE get_diag_rv 
END INTERFACE 
INTERFACE put_diag 

MODULE PROCEDURE put_diag_rv, put_diag_r 
END INTERFACE 
CONTAINS 
!BL 

SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) 
REAL(SP), DIMENSION(:), INTENT(IN) :: src 
REAL(SP), DIMENSION(:), INTENT(OUT) :: dest 
INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied 
n_copied=MIN(SIZE(src),SIZE(dest)) 
n_not_copied=SIZE(src)-n_copied 
dest(l :n_copied)=src(l :n_copied) 
END SUBROUTINE array_copy_r 

!BL 

SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied) 
REAL(DP), DIMENSIONC), INTENT(IN) :: src 
REAL(DP), DIMENSIONC), INTENT(OUT) :: dest 
INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied 
n_copied=MIN(SIZE(src),SIZE(dest)) 
n not_copied=SIZE(src)-n_copied 
dest(l :n_copied)=src(l :n_copied) 
END SUBROUTINE array_copy_d 

!BL 

SUBROUTINE array _copy_i(src,dest,n_copied,n_not_copied) 
INTEGER(I4B), DIMENSIONC), INTENT(IN) :: src 
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INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest 

INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied 

n_copied=MIN(SIZE(src),SIZE(dest)) 

n_not_copied=SIZE(src)-n_copied 

dest(l :n_copied)=src(l :n_copied) 

END SUBROUTINE array_copy_i 

!BL 
!BL 

SUBROUTINE swap_i(a,b) 

INTEGER(I4B), INTENT(INOUT) :: a,b 

INTEGER(I4B) :: dum 

dum=a 

a=b 

b=dum 

END SUBROUTINE swap_i 

!BL 

SUBROUTINE swap_r(a,b) 

REAL(SP), INTENT(INOUT) :: a,b 

REAL(SP) :: dum 

dum=a 

a=b 

b=dum 

END SUBROUTINE swap_r 

!BL 

SUBROUTINE swap_rv(a,b) 

REAL(SP), DIMENSIONO), INTENT(INOUT) :: a,b 

REAL(SP), DIMENSION(SIZE(a)) :: dum 

dum=a 

a=b 

b=dum 

END SUBROUTINE swap_rv 

!BL 

SUBROUTINE swap_c(a,b) 

COMPLEX(SPC), INTENT(INOUT) :: a,b 

COMPLEX(SPC) :: dum 

dum=a 

a=b 

b=dum 

END SUBROUTINE swap_c 

!BL 

SUBROUTINE swap_cv(a,b) 

COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b 

COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum 

dum=a 

a=b 

b=dum 
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END SUBROUTINE swap_cv 

!BL 

SUBROUTINE swap_cm(a,b) 

COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b 

COMPLEX(SPC), DIMENSION(SIZE(a,l),SIZE(a,2)) :: dum 

dum=a 

a=b 

b=dum 

END SUBROUTINE swap_cm 

!BL 

SUBROUTINE masked_swap_rs(a,b,mask) 
REAL(SP), INTENT(INOUT) :: a,b 
LOGICAL(LGT), INTENT(IN) :: mask 
REAL(SP) :: swp 
IF (mask) THEN 

swp=a 

a=b 

b=swp 
END IF 

END SUBROUTINE masked_swap_rs 

!BL 

SUBROUTINE masked_swap_rv(a,b,mask) 
REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b 
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask 
REAL(SP), DIMENSION(SIZE(a)) :: swp 
WHERE (mask) 

swp=a 

a=b 

b=swp 
END WHERE 

END SUBROUTINE masked_swap_rv 

!BL 

SUBROUTINE masked_swap_rm(a,b,mask) 
REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b 
LOGICAL (LGT), DIMENSION^:), INTENT(IN) :: mask 
REAL(SP), DIMENSION(SIZE(a,l),SIZE(a,2)) :: swp 
WHERE (mask) 

swp=a 

a=b 

b=swp 
END WHERE 

END SUBROUTINE masked_swap_rm 

!BL 
!BL 

FUNCTION reallocate_rv(p,n) 

REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv 
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INTEGER(I4B), INTENT(IN) :: n 
INTEGER(I4B) :: nold,ierr 
ALLOCATE(reallocate_rv(n),stat==ierr) 
IF(ierr/=0) CALL & 

nrerror('reallocate_rv: problem in attempt to allocate memory') 
IF (.NOT. ASSOCIATED(p)) RETURN 
nold=SIZE(p) 

reallocate_rv(l :MIN(nold,n))=p(l :MIN(nold,n)) 

DEALLOCATE(p) 

END FUNCTION reallocate_rv 

FUNCTION reallocate_iv(p,n) 

INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv 
INTEGER(I4B), INTENT(IN) :: n 
INTEGER(I4B) :: nold,ierr 
ALLOCATE(reallocate_iv(n),stat=ierr) 
IF (ierr/=0) CALL & 

nrerror('reallocate_iv: problem in attempt to allocate memory') 
IF (.NOT. ASSOCIATED(p)) RETURN 
nold=SIZE(p) 

reallocate_iv(l :MIN(nold,n))=p(l :MIN(nold,n)) 

DEALLOCATED) 

END FUNCTION reallocate_iv 

FUNCTION reallocate_hv(p,n) 

CHARACTER(l), DIMENSION(:), POINTER :: p, reallocate_hv 
INTEGER(I4B), INTENT(IN) :: n 
INTEGER(I4B) :: nold,ierr 
ALLOCATE(reallocate_hv(n),stat=ierr) 
IF (ierr /= 0) CALL & 

nrerror('reallocate_hv: problem in attempt to allocate memory') 
IF (.NOT. ASSOCIATED(p)) RETURN 
nold=SIZE(p) 

reallocate_hv(l :MIN(nold,n))=p(l :MIN(nold,n)) 

DEALLOCATE^) 

END FUNCTION reallocate_hv 

FUNCTION reallocate_rm(p,n,m) 

REAL(SP), DIMENSION(:,:), POINTER :: p, reallocatejm 
INTEGER(I4B), INTENT(IN) :: n,m 
INTEGER(I4B) :: nold,mold,ierr 
ALLOCATE(reallocate_rm(n,m),stat=ierr) 
IF (ierr /= 0) CALL & 

nrerror('reallocate_rm: problem in attempt to allocate memory') 
IF (.NOT. ASSOCIATED(p)) RETURN 
nold=SIZE(p,l) 
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mold=SIZE(p,2) 

reallocate_rm(l :MIN(nold,n), 1 :MIN(mold,m))=& 

p(l :MIN(nold,n),l :MIN(mold,m)) 
DEALLOCATE(p) 
END FUNCTION reallocatejm 

FUNCTION reallocate_im(p,n,m) 

INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im 
INTEGER(I4B), INTENT(IN) :: n,m 
INTEGER(I4B) :: nold,mold,ierr 
ALLOCATE(reallocate_im(n,m),stat=ierr) 
IF (ierr /= 0) CALL & 

nrerror('reallocate_im: problem in attempt to allocate memory') 
IF (.NOT. ASSOCIATED(p)) RETURN 
nold=SIZE(p,l) 
mold=SIZE(p,2) 

reallocate_im(l :MIN(nold,n), 1 :MIN(mold,m))=& 

p( 1 :MIN(nold,n), 1 :MIN(mold,m)) 
DEALLOCATE^) 
END FUNCTION reallocatejm 

FUNCTION ifirstloc(mask) 

LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask 
INTEGER(I4B) :: ifirstloc 
INTEGER(I4B), DIMENSION(l) :: loc 
loc=MAXLOC(MERGE( 1 ,0,mask)) 
ifirstloc=loc(l) 

IF (.NOT. mask(ifirstloc)) ifirstloc=SIZE(mask)+l 
END FUNCTION ifirstloc 

FUNCTION imaxloc_r(arr) 

REAL(SP), DIMENSION(:), INTENT(IN) :: arr 

INTEGER(I4B) :: imaxloc_r 

INTEGER(I4B), DIMENSION(l) :: imax 

imax=MAXLOC(arr(:)) 

imaxloc_r=imax( 1 ) 

END FUNCTION imaxloc_r 

FUNCTION imaxloc_i(iarr) 

INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr 

INTEGER(I4B), DIMENSION(l) :: imax 

INTEGER(I4B) :: imaxloc_i 

imax=MAXLOC(iarr(:)) 

imaxloc_i=imax( 1 ) 

END FUNCTION imaxloc i 
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FUNCTION iminloc(arr) 

REAL(SP), DIMENSIONC), INTENT(IN) :: arr 

INTEGER(I4B), DIMENSION(l) :: imin 

INTEGER(I4B) :: iminloc 

imin=MINLOC(arr(:)) 

iminloc=imin(l) 

END FUNCTION iminloc 

SUBROUTINE assertl (nl ,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
LOGICAL, INTENT(IN) :: nl 
IF (.NOT. nl) THEN 

WRITE (*,*) 'nrerror: an assertion failed with this tag:', & 
string 

STOP 'program terminated by assertl' 
END IF 

END SUBROUTINE assertl 

SUBROUTINE assert2(nl,n2, string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
LOGICAL, INTENT(IN) :: nl,n2 
IF (.NOT. (nl .AND. n2)) THEN 

WRITE (*,*) 'nrerror: an assertion failed with this tag:', & 
string 

STOP 'program terminated by assert2' 
END IF 

END SUBROUTINE assert2 

SUBROUTINE assert3(nl,n2,n3, string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
LOGICAL, INTENT(IN) :: nl,n2,n3 
IF (.NOT. (nl .AND. n2 .AND. n3)) THEN 

WRITE (*,*) 'nrerror: an assertion failed with this tag:', & 
string 

STOP 'program terminated by assert3' 
END IF 

END SUBROUTINE assert3 

SUBROUTINE assert4(nl ,n2,n3,n4,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
LOGICAL, INTENT(IN) :: nl,n2,n3,n4 
IF (.NOT. (nl .AND. n2 .AND. n3 .AND. n4)) THEN 

WRITE (*,*) 'nrerror: an assertion failed with this tag:', & 
string 

STOP 'program terminated by assert4' 
END IF 
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END SUBROUTINE assert4 

SUBROUTINE assert_v(n,string) 
CHARACTER(LEN=* ), INTENT(IN) :: string 
LOGICAL, DIMENSION(:), INTENT(IN) :: n 
IF (.NOT. ALL(n)) THEN 

WRITE (*,*) 'nrerror: an assertion failed with this tag:', & 
string 

STOP 'program terminated by assert_v' 
END IF 

END SUBROUTINE assert_v 

FUNCTION assert_eq2(nl,n2,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
INTEGER, INTENT(IN) :: nl,n2 
INTEGER :: assert_eq2 
IF (nl = n2) THEN 
assert_eq2=nl 

ELSE 

WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', & 
string 

STOP 'program terminated by assert_eq2' 
END IF 

END FUNCTION assert_eq2 

FUNCTION assert_eq3(nl,n2,n3,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
INTEGER, INTENT(IN) :: nl,n2,n3 
INTEGER :: assert_eq3 
IF (nl = n2 .AND. n2 == n3) THEN 
assert_eq3=nl 

ELSE 

WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', & 
string 

STOP 'program terminated by assert_eq3' 
END IF 

END FUNCTION assert_eq3 

FUNCTION assert_eq4(nl ,n2,n3,n4,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
INTEGER, INTENT(IN) :: nl,n2,n3,n4 
INTEGER :: assert_eq4 

IF (nl == n2 .AND. n2 == n3 .AND. n3 == n4) THEN 
assert_eq4=nl 

ELSE 

WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', & 
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string 

STOP 'program terminated by assert_eq4' 
END IF 

END FUNCTION assert_eq4 

FUNCTION assert_eqn(nn,string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
INTEGER, DIMENSION(:), INTENT(IN) :: nn 
INTEGER :: assert_eqn 
IF (ALL(nn(2:) = nn(l))) THEN 
assert_eqn=nn(l) 

ELSE 

WRITE (*,*) 'nrerror: an assert_eq failed with this tag:', & 
string 

STOP 'program terminated by assert_eqn' 
END IF 

END FUNCTION assert_eqn 

SUBROUTINE nrerror(string) 
CHARACTER(LEN=*), INTENT(IN) :: string 
WRITE (*,*) 'nrerror: \string 
STOP 'program terminated by nrerror' 
END SUBROUTINE nrerror 

FUNCTION arth_r(first,increment,n) 
REAL(SP), INTENT(IN) :: first,increment 
INTEGER(I4B), INTENT(IN) :: n 
REAL(SP), DIMENSION(n) :: arth_r 
INTEGER(I4B) :: k,k2 
REAL(SP) :: temp 
IF(n>0)arth_r(l)=first 
IF (n <= NPAR_ARTH) THEN 

DO k=2,n 

arth_r(k)=arth_r(k- 1 )+increment 

END DO 

ELSE 

DO k=2 ,NP AR2_ARTH 

arth_r(k)=arth_r(k- 1 )+increment 
END DO 

temp=increment*NPAR2_ARTH 

k=NPAR2_ARTH 

DO 

IF (k >= n) EXIT 
k2=k+k 

arth_r(k+l :MIN(k2,n))=temp+arth_r(l :MIN(k,n-k)) 
temp=temp+temp 
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k=k2 
END DO 
END IF 

END FUNCTION arth_r 

FUNCTION arth_d(first,increment,n) 
REAL(DP), INTENT(IN) :: first,increment 
INTEGER(I4B), INTENT(IN) :: n 
REAL(DP), DIMENSION(n) :: arth_d 
INTEGER(I4B) :: k,k2 
REAL(DP) :: temp 
IF(n>0)arth_d(l)=first 
IF (n <= NP AR_ARTH) THEN 

DO k=2,n 

arth_d(k)=arth_d(k- 1 )+increment 

END DO 

ELSE 

DO k=2 ,NP AR2ARTH 

arth_d(k)=arth_d(k- 1 )+increment 
END DO 

temp=increment*NPAR2_ARTH 

k=NPAR2_ARTH 

DO 

IF (k >= n) EXIT 
k2=k+k 

arth_d(k+l :MIN(k2,n)Hemp+arth_d(l :MIN(k,n-k)) 
temp=temp+temp 
k=k2 
END DO 
END IF 

END FUNCTION arth_d 

FUNCTION arth_i(first,increment,n) 

INTEGER(I4B), INTENT(IN) :: first,increment,n 

INTEGER(I4B), DIMENSION(n) :: arth_i 

INTEGER(I4B) :: k,k2,temp 

IF(n>0) arth_i(l)=first 

IF (n <= NPAR ARTH) THEN 

DO k=2,n 

arth_i(k)=arth_i(k- 1 )+increment 

END DO 

ELSE 

DO k=2,NPAR2_ARTH 

arth_i(k)=arth_i(k- 1 )+increment 
END DO 

temp=increment*NPAR2_ARTH 
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k=NPAR2_ARTH 
DO 

IF (k >= n) EXIT 
k2=k+k 

arth_i(k+ 1 :MIN(k2,n))=temp+arth_i(l :MIN(k,n-k)) 
temp=temp+temp 
k=k2 
END DO 
END IF 

END FUNCTION arth_i 

!BL 
!BL 

FUNCTION geop_r(first,factor,n) 

REAL(SP), INTENT(IN) :: first,factor 

INTEGER(I4B), INTENT(IN) :: n 

REAL(SP), DIMENSION(n) : : ge'op.r 

INTEGER(I4B)::k,k2 

REAL(SP) :: temp 

IF (n > 0) geop_r(l)=first 

IF (n <= NPAR GEOP) THEN 

DO k=2,n 

geop_r(k)=geop_r(k- 1 )*factor 

END DO 

ELSE 

DO k=2,NPAR2_GEOP 

geop_r(k)=geop_r(k- 1 ) * factor 
END DO 

temp=factor* *NP AR2_GEOP 

k=NPAR2_GEOP 

DO 

IF (k >= n) EXIT 
k2=k+k 

geop_r(k+l :MIN(k2,n))=temp*geop_r(l :MIN(k,n-k)) 
temp=temp*temp 
k=k2 
END DO 
END IF 

END FUNCTION geop_r 

!BL 

FUNCTION geop_d(first,factor,n) 

REAL (DP), INTENT(IN) :: first,factor 

INTEGER(I4B), INTENT(IN) :: n 

REAL (DP), DIMENSION(n) :: geop_d 

INTEGER(I4B) :: k,k2 

REAL(DP) :: temp 

IF (n > 0) geop_d(l)=first 
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IF (n <= NPAR_GEOP) THEN 
DO k=2,n 

geop_d(k)=geop_d(k- 1 )*factor 
END DO 

ELSE 

DO k=2,NPAR2_GEOP 

geop_d(k)=geop_d(k- 1 ) * factor 
END DO 

temp=factor* *NP AR2_GEOP 

k=NPAR2_GEOP 

DO 

IF (k >= n) EXIT 
k2=k+k 

geop_d(k+l :MIN(k2,n))=temp*geop_d(l :MIN(k,n-k)) 
temp=temp*temp 
k=k2 
END DO 
END IF 

END FUNCTION geop_d 

FUNCTION geop_i(first,factor,n) 

INTEGER(I4B), INTENT(IN) :: first,factor,n 

INTEGER(I4B), DIMENSION(n) :: geop_i 

INTEGER(I4B) :: k,k2,temp 

IF (n > 0) geop_i(l)=first 

IF (n <= NPAR_GEOP) THEN 

DO k=2,n 

geop_i(k)=geop_i(k- 1 )*factor 

END DO 

ELSE 

DO k=2,NPAR2_GEOP 

geop_i(k)=geop_i(k- 1 ) * factor 
END DO 

temp=factor* *NPAR2_GEOP 

k=NPAR2_GEOP 

DO 

IF (k >= n) EXIT 
k2=k+k 

geop_i(k+l :MIN(k2,n))=temp*geop_i(l :MIN(k,n-k)) 
temp=temp * temp 
k=k2 
END DO 
END IF 

END FUNCTION geop_i 
FUNCTION geop_c(first,factor,n) 
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COMPLEX(SP), INTENT(IN) :: first,factor 

INTEGER(I4B), INTENT(IN) :: n 

COMPLEX(SP), DIMENSION(n) :: geop_c 

INTEGER(I4B)::k,k2 

COMPLEX(SP) :: temp 

IF (n>0) geop_c(l)=first 

IF (n <= NPAR_GEOP) THEN 

DO k=2,n 

geop_c(k)=geop_c(k- 1 )* factor 

END DO 

ELSE 

DO k=2,NPAR2_GEOP 

geop_c(k)=geop_c(k- 1 ) * factor 
END DO 

temp=factor * *NP AR2_GEOP 

k=NPAR2_GEOP 

DO 

IF (k >= n) EXIT 
k2=k+k 

geop_c(k+l :MIN(k2,n))=temp*geop_c(l :MIN(k,n-k)) 
temp=temp *temp 
k=k2 
END DO 
END IF 

END FUNCTION geop_c 

FUNCTION geop_dv(first,factor,n) 

REAL(DP), DIMENSIONO), INTENT(IN) :: first,factor 

INTEGER(I4B), INTENT(IN) :: n 

REAL(DP), DIMENSION(SIZE(first),n) :: geop_dv 

INTEGER(I4B) :: k,k2 

REAL(DP), DIMENSION(SIZE(first)) :: temp 
IF (n > 0) geop_dv(:,l)=first(:) 
IF (n <= NPAR_GEOP) THEN 

DOk=2,n 

geop_dv( : ,k)=geop_dv( : ,k- 1 ) * factor( :) 

END DO 

ELSE 

DO k=2,NPAR2_GEOP 

geop_dv(:,k)=geop_dv(:,k- 1 )*factor(:) 
END DO 

temp=factor* *NP AR2_GEOP 

k=NPAR2_GEOP 

DO 

IF (k >= n) EXIT 
k2=k+k 
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geop_dv(:,k+l :MIN(k2,n))=geop_dv(:, 1 :MIN(k,n-k))*& 

SPREAD(temp,2,SIZE(geop_dv(:, 1 :MIN(k,n-k)),2)) 
temp=temp * temp 
k=k2 
END DO 
END IF 

END FUNCTION geop_dv 

!BL 
!BL 

RECURSIVE FUNCTION curnsum_r(arr,seed) RESULT(ans) 

REAL(SP), DIMENSIONC), INTENT(IN) :: arr 

REAL(SP), OPTIONAL, INTENT(IN) :: seed 

REAL(SP), DIMENSION(SIZE(arr)) :: ans 

INTEGER(I4B) :: nj 

REAL(SP) :: sd 

n=SIZE(arr) 

IF (n = 0_i4b) RETURN 
sd=0.0_sp 

IF (PRESENT(seed)) sd=seed 
ans(l)=arr(l)+sd 

IF (n < NPAR_CUMSUM) THEN 
DOj=2,n 

ans(j )=ans(j - 1 )+arr(j ) 
END DO 

ELSE 

ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(l :n-l :2),sd) 
ans(3:n:2)=ans(2:n-l :2)+arr(3:n:2) 
END IF 

END FUNCTION cumsum_r 

!BL 

RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr 
INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed 
INTEGER(I4B), DIMENSION(SIZE(arr)) :: ans . 
INTEGER(I4B) :: n,j,sd 
n=SIZE(arr) 

IF (n == 0_i4b) RETURN 
sd=0_i4b 

IF (PRESENT(seed)) sd=seed 
ans(l)=arr(l)+sd 

IF (n < NPAR_CUMSUM) THEN 
DOj=2,n 

ans(j )=ans(j - 1 )+arr(j ) 
END DO 

ELSE 

ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(l :n-l :2),sd) 
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ans(3:n:2)=ans(2:n-l :2)+arr(3:n:2) 
END IF 

END FUNCTION cumsum_i 

!BL 
!BL 

RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) 
REAL(SP), DIMENSIONO), INTENT(IN) :: arr 
REAL(SP), OPTIONAL, INTENT(IN) :: seed 
REAL(SP), DIMENSION(SIZE(arr)) :: ans 
INTEGER(I4B) :: nj 
REAL(SP) :: sd 
n=SIZE(arr) 

IF (n == 0_i4b) RETURN 
sd=1.0_sp 

IF (PRESENT(seed)) sd=seed 
ans(l)=arr(l)*sd 

IF (n < NPAR_CUMPROD) THEN 
DOj=2,n 

ans(i)=ans(j-l)*arr(i) 
END DO 

ELSE 

ans(2:n:2)=cumprod(arr(2:n:2)*arr(l :n-l :2),sd) 
ans(3:n:2)=ans(2:n-l:2)*arr(3:n:2) 
END IF 

END FUNCTION cumprod 

!BL 
!BL 

FUNCTION poly_rr(x,coeffs) 

REAL(SP), INTENT(IN) :: x 

REAL(SP), DIMENSIONO), INTENT(IN) :: coeffs 

REAL(SP)::poly_rr 

REAL(SP) :: pow 

REAL(SP), DIMENSIONO), ALLOC AT ABLE :: vec 
INTEGER(I4B) :: i,n,nn 
n=SIZE(coeffs) 
IF (n <= 0) THEN 

poly_rr=0.0_sp 
ELSE IF (n < NPAR POLY) THEN 

poly_rr=coeffs(n) 

DO i=n-l,l,-l 

poly_rr=x * poly_rr+coeffs(i) 

END DO 

ELSE 

ALLOCATE(vec(n+l)) 
pow=x 

vec(l:n)=coeffs 
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DO 

vec(n+l)=0.0_sp 
nn=ISHFT(n+l,-l) 

vec(l :nn)=vec(l :n:2)+pow*vec(2:n+l :2) 

IF (nn= 1)EXIT 

pow=pow*pow 

n=nn 
END DO 
poly_rr=vec(l) 
DEALLOCATE(vec) 
END IF 

END FUNCTION poly_rr 

!BL 

FUNCTION poly_dd(x,coeffs) 

REAL(DP), INTENT(IN) :: x 

REAL(DP), DIMENSION^), INTENT(IN) :: coeffs 

PvEAL(DP) :: poly_dd 

REAL(DP) :: pow 

REAL(DP), DIMENSIONO), ALLOCATABLE :: vec 
INTEGER(I4B) :: i,n,nn 
n=SIZE(coeffs) 
IF (n <= 0) THEN 

poly_dd=0.0_dp 
ELSE IF (n < NPAR POLY) THEN 

poly_dd=coeffs(n) 

DO i=n-l,l,-l 

poly_dd=x*poly_dd+coeffs(i) 

END DO 

ELSE 

ALLOCATE(vec(n+l)) 
pow=x 

vec(l:n)=coeffs 
DO 

vec(n+l)=0.0_dp 
nn=ISHFT(n+l,-l) 

vec( 1 : nn)=vec( 1 :n : 2)+pow* vec(2 :n+ 1 : 2) 

IF (nn = 1) EXIT 

pow=pow*pow 

n=nn 
END DO 
poly_dd=vec(l) 
DEALLOCATE(vec) 
END IF 

END FUNCTION poly_dd 

!BL 

FUNCTION poly_rc(x,coeffs) 
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COMPLEX(SPC), INTENT(IN) :: x 
REAL(SP), DIMENSIONO), INTENT(IN) :: coeffs 
COMPLEX(SPC) :: poly_rc 
COMPLEX(SPC) :: pow 

COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec 
INTEGER(I4B) :: i,n,nn 
n=SIZE(coeffs) 
IF (n <= 0) THEN 

poly_rc=0.0_sp 
ELSE IF (n < NPARPOLY) THEN 

poly_rc=coeffs(n) 

DO i=n-l,l,-l 

poly_rc=x*poly_rc+coeffs(i) 

END DO 

ELSE 

ALLOCATE(vec(n+l)) 
pow=x 

vec(l:n)=coeffs 
DO 

vec(n+l)=0.0_sp 
nn=ISHFT(n+l,-l) 

vec(l :nn)=vec(l :n:2)+pow*vec(2:n+l :2) 

IF (nn = 1) EXIT 

pow=pow*pow 

n=nn 
END DO 
poly_rc=vec(l) 
DEALLOCATE(vec) 
END IF 

END FUNCTION poly_rc 

FUNCTION poly_cc(x,coeffs) 

COMPLEX(SPC), INTENT(IN) :: x 

COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs 

COMPLEX(SPC) :: poly_cc 

COMPLEX(SPC) :: pow 

COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec 
INTEGER(I4B) :: i,n,nn 
n=SIZE(coeffs) 
IF (n <= 0) THEN 

poly_cc=0.0_sp 
ELSE IF (n < NPAR POLY) THEN 

poly_cc=coeffs(n) 

DO i=n-l,l,-l 

poly_cc=x*poly_cc+coeffs(i) 

END DO 



[nrutil.190] 



f 

ELSE 

ALLOCATE(vec(n+l)) 
pow=x 

vec(l:n)=coeffs 
DO 

vec(n+l)=0.0_sp 
nn=ISHFT(n+l,-l) 

vec(l :nn)=vec(l :n:2)+pow*vec(2:n+l :2) 

IF (nn = 1)EXIT 

pow=pow*pow 

n=nn 
END DO 
poly_cc=vec(l) 
DEALLOCATE(vec) 
END IF 

END FUNCTION poly_cc 

FUNCTION poly_rrv(x,coeffs) 

REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x 

REAL(SP), DIMENSION(SIZE(x)) :: poly_rrv 

INTEGER(I4B) :: i,n,m 

m=SIZE(coeffs) 

n=SIZE(x) 

IF (m <= 0) THEN 

poly_rrv=0.0_sp 
ELSE IF (m< n .OR. m < NPARPOLY) THEN 

poly_rrv=coeffs(m) 

DO i=m-l,l,-l 

poly_rrv=x * poly_rrv+coeffs(i) 

END DO 

ELSE 

DO i=l,n 

poly_rrv(i)=poly_rr(x(i),coeffs) 
END DO 
END IF 

END FUNCTION poly_rrv 

FUNCTION poly_ddv(x,coeffs) 

REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x 

REAL(DP), DIMENSION(SIZE(x)) :: poly_ddv 

INTEGER(I4B) :: i,n,m 

m=SIZE(coeffs) 

n=SIZE(x) 

IF (m <= 0) THEN 

poly_ddv=0.0_dp 
ELSE IF (m< n .OR. m < NPAR_POLY) THEN 
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poly_ddv=coeffs(m) 
DO i=m-l,l,-l 

poly_ddv=x*poly_ddv+coeffs(i) 
END DO 

ELSE 

DOi=l,n 

poly_ddv(i)=po ly_dd(x(i),coeffs) 
END DO 
END IF 

END FUNCTION poly_ddv 

!BL 

FUNCTION poly_msk_rrv(x,coeffs,mask) 
REAL(SP), DIMENSIONO), INTENT(IN) :: coeffs,x 
LOGICAL (LGT), DIMENSIONO), INTENT(IN) :: mask 
REAL(SP), DIMENSION(SIZE(x)) :; poly_msk_rrv 
poly_msk_rrv=UNPACK(poly_rrv(PACK(x,mask),coeffs),mask,0.0_sp) 
END FUNCTION poly_msk_rrv 

!BL 

FUNCTION poly_msk_ddv(x,coeffs,mask) 
REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x 
LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask 
REAL(DP), DIMENSION(SIZE(x)) :: poly_msk_ddv 
poly_msk_ddv=UNPACK(poly_ddv(PACK(x,mask),coefrs),mask,0.0_dp) 
END FUNCTION poly_msk_ddv 

!BL 
!BL 

RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) 
REAL(SP), DIMENSIONO), INTENT(IN) :: a 
REAL(SP), INTENT(IN) :: b 
REAL(SP), DIMENSION(SIZE(a)) :: u 
INTEGER(I4B) :: n,j 
n=SIZE(a) 

IF (n <= 0) RETURN 
u(l)=a(l) 

IF (n < NPAR POLYTERM) THEN 
DOj=2,n 

uO)=aG)+b*uC-l) 
END DO 

ELSE 

u(2:n:2)=poly_term_rr(a(2:n:2)+a(l :n-l :2)*b,b*b) 
u(3:n:2)=a(3:n:2)+b*u(2:n-l:2) 
END IF 

END FUNCTION poly_term_rr 

!BL 

RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) 
COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a 
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COMPLEX(SPC), INTENT(IN) :: b 
COMPLEX(SPC), DIMENSION(SIZE(a)) :: u 
INTEGER(I4B) :: n,j 
n=SIZE(a) 

IF (n <= 0) RETURN 
u(l)=a(l) 

IF (n <NPAR_POLYTERM) THEN 
DOj=2,n 

u(j)=aG)+b*u(j-l) 
END DO 

ELSE 

u(2:n:2)=poly_term_cc(a(2:n:2)+a(l :n-l :2)*b,b*b) 
u(3:n:2)=a(3 :n:2)+b*u(2:n-l :2) 
END IF 

END FUNCTION poly_term_ce 

!BL 
!BL 

FUNCTION zroots_unity(n,nn) 

INTEGER(I4B), INTENT(IN) :: n,nn 

COMPLEX(SPC), DIMENSION(nn) :: zroots_unity 

INTEGER(I4B) :: k 

REAL(SP) :: theta 

2xoots_unity ( 1 )= 1 .0 

theta=TWOPI/n 

k=l 

DO 

IF(k>=nn)EXIT 

zroots_unity(k+ 1 )=CMPLX(COS(k*theta),SIN(k*theta),SPC) 
zroots_unity(k+2:MIN(2*k,nn))=zroots_unity(k+l)*& 
zroots_unity(2 :MIN(k,nn-k)) 

k=2*k 
END DO 

END FUNCTION zroots_unity 

!BL 

FUNCTION outerprod_r(a,b) 
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b 
REAL(SP), DIMENSION(SIZE(a),SIZE(b)) :: outerprod_r 
outerprod_r = SPREAD(a,dim=2,ncopies=SIZE(b)) * & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerprod_r 

!BL 

FUNCTION outerprod_d(a,b) 
REAL(DP), DIMENSIONC), INTENT(IN) :: a,b 
REAL(DP), DIMENSION(SIZE(a),SIZE(b)) :: outerprod_d 
outerprod_d = SPREAD(a,dim=2,ncopies=SIZE(b)) * & 
SPREAD(b,dim=l,ncopies=SIZE(a)) 
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END FUNCTION outerprod_d 

!BL 

FUNCTION outerdiv(a,b) 
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b 
REAL(SP), DIMENSION(SIZE(a),SIZE(b)) :: outerdiv 
outerdiv = SPREAD(a,dim=2,ncopies=SIZE(b)) / & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerdiv 

!BL 

FUNCTION outersum(a,b) 
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b 
REAL(SP), DIMENSION(SIZE(a),SIZE(b)) :: outersum 
outersum = SPREAD(a,dim=2,ncopies=SIZE(b)) + & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outersum 

!BL 

FUNCTION outerdiff_r(a,b) 
REAL(SP), DIMENSION(:), INTENT(IN) :: a,b 
REAL(SP), DIMENSION(SIZE(a),SIZE(b)) :: outerdiff_r 
outerdiffj = SPREAD(a,dim=2,ncopies=SIZE(b)) - & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerdiff_r 

!BL 

FUNCTION outerdiff_d(a,b) 
REAL(DP), DIMENSION(:), INTENT(IN) :: a,b 
REAL(DP), DIMENSION(SIZE(a),SIZE(b)) :: outerdiff_d 
outerdiff_d = SPREAD(a,dim=2,ncopies=SIZE(b)) - & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerdiff_d 

!BL 

FUNCTION outerdiff_i(a,b) 

INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b 
INTEGER(I4B), DIMENSION(SIZE(a),SIZE(b)) :: outerdiffj 
outerdiffj = SPREAD(a,dim=2,ncopies=SIZE(b)) - & 

SPREAD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerdiffj 

!BL 

FUNCTION outerand(a,b) 

LOGICAL(LGT), DIMENSION(:) 5 INTENT(IN) :: a,b 
LOGIC AL(LGT), DIMENSION(SIZE(a),SIZE(b)) :: outerand 
outerand = SPREAD(a,dim=2,ncopies=SIZE(b)) .AND. & 

SPRE AD(b,dim=l ,ncopies=SIZE(a)) 
END FUNCTION outerand 

!BL 

SUBROUTINE scatter_add_r(dest,source,dest index) 
REAL(SP), DIMENSION(:), INTENT(OUT) :: dest 
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REAL(SP), DIMENSIONO), INTENT(IN) :: source 
INTEGER(I4B), DIMENSIONO), INTENT(IN) :: dest_index 
INTEGER(I4B) :: m,nj,i 

n=assert_eq2(SIZE(soiirce),SIZE(destJndex), , scatter_add_r') 

m=SIZE(dest) 

DOj=l,n 

i=dest_index(j) 

IF (i > 0 .AND. i <= m) dest(i)=dest(i)+source(j) 
END DO 

END SUBROUTINE scatter_add_r 
SUBROUTINE scatter_add_d(dest,source,dest_index) 
REAL (DP), DIMENSIONO), INTENT(OUT) :: dest 
REAL (DP), DIMENSIONO), INTENT(IN) :: source 
INTEGER(I4B), DIMENSIONO), INTENT(IN) :: dest_index 
INTEGER(I4B) :: m,nj,i 

n=assert_eq2(SIZE(source),SIZE(dest_index),'scatter_add_d') 

m=SIZE(dest) 

DOj=l,n 

i=dest_index(j) 

IF (i > 0 .AND. i <= m) dest(i)=dest(i)+sourceG) 
END DO 

END SUBROUTINE scatter_add_d 
SUBROUTINE scatter_max_r(dest,source,dest_index) 
REAL(SP), DIMENSIONO), INTENT(OUT) :: dest 
REAL(SP), DIMENSION(:), INTENT(IN) :: source 
INTEGER(I4B), DIMENSIONO), INTENT(IN) :: dest_index 
INTEGER(I4B) :: m,n,j,i 

n=assert_eq2(SIZE(source),SIZE(dest_index),'scatter_max_r') 

m=SIZE(dest) 

DOj=l,n 

i=dest_index(j) 

IF (i > 0 .AND. i <= m) dest(i)=MAX(dest(i),sourceG)) 
END DO 

END SUBROUTINE scatter_max_r 
SUBROUTINE scatter_max_d(dest,source,dest_index) 
REAL(DP), DIMENSION(:), INTENT(OUT) :: dest 
REAL(DP), DIMENSIONO, INTENT(IN) :: source 
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index 
INTEGER(I4B) :: m,n,j,i 

n=assert_eq2(SIZE(source),SIZE(dest_index),'scatter_max_d') 

m=SIZE(dest) 

DOj=l,n 

i=dest_index(j) 

IF (i > 0 .AND. i <= m) dest(i)=MAX(dest(i),source(j)) 
END DO 

END SUBROUTINE scatter max d 
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SUBROUTINE diagadd_rv(mat,diag) 
REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: mat 
REAL(SP), DIMENSION(:), INTENT(IN) :: diag 
INTEGER(I4B) :: j,n 

n = assert_eq2(SIZE(diag),MIN(SIZE(mat, 1 XSIZECmat^VdiagaddjV) 
DOj=l,n 

mat(j,j)=matOJ)+diagO) 
END DO 

END SUBROUTINE diagadd_rv 

SUBROUTINE diagadd_r(mat,diag) 

REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat 

REAL(SP), INTENT(IN) :: diag 

INTEGER(I4B) :: j,n 

n = MIN(SIZE(mat,l),SIZE(mat,2)) 

DOj=l,n 

mat(jj)=matO,j)+diag 
END DO 

END SUBROUTINE diagadd_r 

SUBROUTINE diagmult_rv(mat,diag) 
REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: mat 
REAL(SP), DIMENSIONO, INTENT(IN) :: diag 
INTEGER(I4B) ::j,n 

n = assert_eq2(SIZE(diag),MIN(SIZE(mat, 1 ),SIZE(mat > 2)),'diagmult_rv') 
DOj=l,n 

mat(j,j)=mat(j,j)*diagO) 
END DO 

END SUBROUTINE diagmult_rv 

SUBROUTINE diagmult_r(mat,diag) 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: mat 

REAL(SP), INTENT(IN) :: diag 

INTEGER(I4B) ::j,n 

n = MIN(SIZE(mat,l),SIZE(mat,2)) 

DOj=l,n 

mat(jj)=mat(i,j)*diag 
END DO 

END SUBROUTINE diagmult r 

FUNCTION get_diag_rv(mat) 

REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat 

REAL(SP), DIMENSION(SIZE(mat,l)) :: get_diag_rv 

INTEGER(I4B)::j 

j=assert_eq2(SIZE(mat, 1 ),SIZE(mat ) 2);get_diag_rv') 
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DOj=l,SIZE(mat,l) 

get_diag_rv(j)=mat(j j) 
END DO 

END FUNCTION get_diag_rv 

!BL 

FUNCTION get_diag_dv(mat) 
REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat 
REAL(DP), DIMENSION(SIZE(mat,l)) :: get_diag_dv 
INTEGER(I4B) ::j 

j=assert_eq2(SIZE(mat, 1 ),SIZE(mat,2),'get_diag_dv') 
DOj=l,SIZE(mat,l) 

get_diag_dv(j)=matO j) 
END DO 

END FUNCTION get_diag_dv 

!BL 

SUBROUTINE put_diag_rv(diagv,mat) 
REAL(SP), DIMENSIONO), INTENT(IN) : : diagv 
REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: mat 
INTEGER(I4B) ::j,n 

n=assert_eq2(SIZE(diagv),MIN(SIZE(mat,l),SIZE(mat,2)), , put_diag_rv') 
DOj=l,n 

matO,j)=diagvG) 
END DO 

END SUBROUTINE put_diag_rv 

!BL 

SUBROUTINE put_diag_r(scal,mat) 

REAL(SP), INTENT(IN) :: seal 

REAL(SP), DIMENSIONO,:), INTENT(INOUT) :: mat 

INTEGER(I4B) :: j,n 

n = MIN(SIZE(mat,l),SIZE(mat,2)) 

DOj=l,n 

mat(j,j)=scal 
END DO 

END SUBROUTINE put_diag_r 

!BL 

SUBROUTINE unit_matrix(mat) 

REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat 

INTEGER(I4B) :: i,n 

n=MIN(SIZE(mat, l),SIZE(mat,2)) 

mat(:,:)=0.0_sp 

DO i=l,n 

mat(i,i)=1.0_sp 
END DO 

END SUBROUTINE unit_matrix 

!BL 

FUNCTION upper_triangle(j,k,extra) 
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INTEGER(I4B), INTENT(IN) :: j,k 
INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra 
LOGICAL(LGT), DIMENSIONG.k) :: upperjriangle 
INTEGER(I4B) :: n 
n=0 

IF (PRESENT(extra)) n=extra 

upper_triangle=(outerdiff(arth_i(l,l,j),arth_i(l,l,k)) < n) 
END FUNCTION upperjriangle 

!BL 

FUNCTION lower_triangle(j,k,extra) 
INTEGER(I4B), INTENT(IN) :: j,k 
INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra 
LOGIC AL(LGT), DIMENSION(j,k) :: lowerjriangle 
INTEGER(I4B) :: n 
n=0 

IF (PRESENT(extra)) n=extra 

lower_triangle=(outerdiff(arth_i(l,l j),arth_i(l,l,k)) > -n) 
END FUNCTION lowerjriangle 

!BL 

FUNCTION vabs(v) 

REAL(SP), DIMENSIONC), INTENT(IN) :: v 
REAL(SP) :: vabs 

vabs=SQRT(DOT_PRODUCT(v,v)) 
END FUNCTION vabs 

!BL 

END MODULE nrutil 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 



Time-stamp: <98/06/22 06:20:55 ayahil> 



! ! ! Computation parameters held in a module for use by the minimization & 
! ! ! other routines. 

MODULE Parm 

USE Nrtype 
IMPLICIT NONE 

TYPE Submatrixjag 

INTEGER, DIMENSIONC), POINTER :: idx 
END TYPE Submatrixjag 

INTEGER :: iflag, k 

INTEGER, ALLOCATABLE, DIMENSION(:) :: idx 
INTEGER, POINTER :: n, p 
REAL(sp) :: norm 

REAL(sp), ALLOCATABLE, DIMENSION(:) :: diagv 
REAL(sp), POINTER, DIMENSION(:) :: w 
REAL(sp), POINTER, DIMENSION(:,:) :: r 
TYPE(Submatrix_tag), ALLOCATABLE, DIMENSION(:) :: sm 

END MODULE Parm 
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I***************************************** 

! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/15 20:18:51 ayahil> 

! ! ! Generate a random premutation of the indices l,...,n. This routine uses 
!!! completely independent random generators to avoid interfering with other 
! ! ! random number generation. 

FUNCTION Permute( n, seed ) RESULT( out ) 

USE Dfport, ONLY: Time 

USE Mynr, ONLY: My_ranl 

USE My_ran_state, ONLY: My_ran_seed 

USE Nr, ONLY: Indexx 

USE Nrtype 

IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: n 
INTEGER, OPTIONAL, INTENT(in) :: seed 
INTEGER, DIMENSION(n) :: out 

! Locals 

REAL(sp), DIMENSION(n) :: t 

! Change the seed of the random-number 

! generator 
IF( PRESENT(seed) ) THEN 
CALL My_ran_seed( seed ) 
ELSE 

CALL My_ran_seed( Time() ) 
END IF 

! Generate real random numbers 
CALLMy_ranl(t) 

! The sort indices of the random numbers are 

! the random permutation 
CALL Indexx( t, out ) 

END 
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***************************************** 

Copyright (C) 1998 by Algebron LLC. 

All rights reserved. 

Unauthorized reproduction prohibited. 
***************************************** 

Time-stamp: <98/06/29 11:49:28 ayahil> 



! Prepare a matrix of mean-subtracted returns of securities in the form of 
! percentages. Returns are provided only where prices exist for the date in 
! question and the previous date. Otherwise, set return to -999. 
! Securities that do not have at least CNTMN returns, making up at least a 
! fraction PRUNE of the dates on which the securities existed are eliminated 
! completely. 



SUBROUTINE Prepare( & 



& cntmn, & 


! Minimum count of valid securities 


& idx, & 


! Index list of valid securities after pruning 


&n,& 


! # of samples 


&p,& 


! # of valid securities after pruning 


&p0,& 


! Total # of securities 


& prune, & 


! Pruning fraction 


&r, & 


! Mean-subtracted returns 


& ravg, & 


! Mean returns 


& w, & 


! Weights 


&X& 


! Prices 


&) 





USE Nrtype 

USE Nrutil, ONLY: Assert_eq, Ifirstloc 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(in) :: cntmn, n, pO 
INTEGER, INTENT(out) :: p 
INTEGER, INTENT(out), DIMENSION(pO) :: idx 
REAL(sp), INTENT(in) :: prune 
REAL(sp), INTENT(in), DIMENSION(n) :: w 
REAL(sp), INTENT(in), DIMENSION(n,pO) :: x 
REAL(sp), INTENT(out), DIMENSION(n,pO) :: r 
REAL(sp), INTENT(out), DIMENSION(pO) :: ravg 

! Locals 
INTEGER:: chk,cnt,j 
LOGICAL, DIMENSION(n) :: msk 

! Check sizes 

chk = Assert_eq( n, SIZE(r,l), SIZE(w), SIZE(x,l), ' Prepare-n' ) 
chk = Assert_eq( (/ pO, SIZE(idx), SIZE(r,2), SIZE(ravg), SIZE(x,2) /), & 
& ' Prepare-pO' ) 
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! Verify that the weights are non-negative 
IF( ANY( w < 0.0_sp ) ) STOP "The weights may not be negative 1 
! Compute the returns with mean subtracted & 
! prune the securities with too few returns 

p = 0 

DOj = l,pO 

msk = x(: j) > 0 .AND. EOSHIFT( x(:,j), -1 ) > 0 
WHERE( msk ) 

r(:,j) = 100.0_sp*(x(: j)/EOSHIFT( x(: j), -1 ) - 1.0_sp) 
ELSEWHERE 

r(:,j) = -999.0_sp 
END WHERE 
cnt = COUNT( msk ) 

IF( cnt > MAX( REAL( cntmn, KIND=KIND(prune) ), & 
& prune*(n + 1 - Ifirstloc( x(: j) /= 0.0_sp ) & 
& - Ifirstloc( x(n: 1 :- 1 j) /= 6.0_sp ) ) ) ) THEN 

ravgG) = SUM( w*r(: j), MASK=msk )/SUM( w, MASK=msk ) 

WHERE( msk ) 

r(:,j) = r(: J) - ravgG) 

END WHERE 

p = p+l 

idx(p)=j 
ELSE 

msk = .FALSE. 

r(: j) = -999.0_sp 

ravgG) = -999.0_sp 
END IF 
END DO 



END SUBROUTINE Prepare 
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/****************************************** 

/* Copyright (C) 1998 by Algebron LLC. 

/* All rights reserved. 

/* Unauthorized reproduction prohibited. 

I* ***************************************** */ 

/* Time-stamp: <98/07/24 07:59:58 ayahil> */ 



Prepare a matrix of mean-subtracted returns of securities in the form of 
percentages. Returns are provided only where prices exist for the date in 
question and the previous date. Otherwise, set return to -999. Securities 
that do not have at least CNTMN returns, making up at least a fraction PRUNE 
of the dates on which the securities existed, are eliminated completely. 

*/ 

#ifhdefPREPARE_H 
#define PREPARE H 



void prepare_( 

int* cntmn, 



int* idx, 



int* n, 
int* p, 
int* pO, 
double* prune, 



/* Acceptance criterion: minimum # of returns. 

Input [default=10] */ 
/* Index list of accepted securities. Output 

array(p0)*/ 
/* Total # of security samplings. Input */ 
/* # of accepted securities. Output */ 
/* Total # of securities considered. Input */ 
/* Acceptance criterion: minimum fraction of 
sampled returns during the lifetime of the 
securities. Input [default=10] */ 
double* r, /* Mean subtracted returns as percentages; 

invalid returns are set to -999. Output 
array (n,pO) */ 
/* Means of valid returns, set to -999 for 
securites which were not accepted. Output 
array (pO) */ 
/* Time weighting of the securities in the 
computation of the covariance matrix. Input 
array(n) */ 
/* Price history of the securities. Input 
array (n,p0) */ 



double* ravg, 



double* w, 



double* x 



); 



int cntmn_def =10; 



double prune_def = 0.2; 
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#endif 



THIS PAGE BLANK (uspto) 
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FUNCTION pythag_sp(a,b) 

USE nrtype 

IMPLICIT NONE 

REAL(SP), INTENT(IN) :: a,b 

REAL(SP) :: pythag_sp 

REAL(SP) :: absa,absb 

absa=abs(a) 

absb=abs(b) 

if (absa > absb) then 

pythag_sp=absa* sqrt( 1 .0_sp+(absb/absa)* * 2) 

else 

if(absb = 0.0) then 
pythag_sp=0.0 

else 

pythag_sp=absb* sqrt( 1 .0_sp+(absa/absb)* *2) 

end if 

end if 

END FUNCTION pythag_sp 

FUNCTION pythag_dp(a,b) 

USE nrtype 

IMPLICIT NONE 

REAL(DP), INTENT(IN) : : a ? b 

REAL(DP) :: pythag_dp 

REAL(DP) :: absa,absb 

absa=abs(a) 

absb=abs(b) 

if (absa > absb) then 

pythag_dp=absa*sqrt(1.0_dp+(absb/absa)**2) 

else 

if (absb = 0.0) then 
pythag_dp=0.0 

else 

pythag_dp=absb*sqrt(1.0_dp+(absa/absb)**2) 

end if 

end if 

END FUNCTION pythag_dp 
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MODULE ran_state 
USE nrtype 
IMPLICIT NONE 

INTEGER, PARAMETER :: K4B=selected_int_kind(9) 
INTEGER(K4B), PARAMETER :: hg=huge(l_K4B), hgm=-hg, hgng=hgm-l 
INTEGER(K4B), SAVE :: lenran=0, seq=0 
INTEGER(K4B), SAVE :: iranOjranO s kranO ? nran0 5 mranO,rans 
INTEGER(K4B), DIMENSION(:,:), POINTER, SAVE :: ranseeds 
INTEGER(K4B), DIMENSION(:), POINTER, SAVE :: iran,jran,kran, & 

nran,mran,ranv 
REAL(SP), SAVE :: amm 
INTERFACE ran_hash 

MODULE PROCEDURE ran_hash_s, ran_hash_v 
END INTERFACE 

CONTAINS 

!BL 

SUBROUTINE ran_init(length) 

USE nrtype; USE nrutil, ONLY : arth,nrerror,reallocate 

IMPLICIT NONE 

INTEGER(K4B), INTENT(IN) :: length 
INTEGER(K4B) :: newj,hgt 
if (length < lenran) RETURN 
hgt=hg 

if (hg /= 2147483647) call nrerror('ranJnit: arith assump 1 fails') 
if (hgng >= 0) call nrerror('ran_init: arith assump 2 fails') 
if (hgt+1 /= hgng) call nrerror('ran_init: arith assump 3 fails') 
if (not(hg) >= 0) call nrerror('ran_init: arith assump 4 fails') 
if (not(hgng) < 0) call nrerror('ran_init: arith assump 5 fails') 
if (hg+hgng >= 0) call nrerror('ran_init: arith assump 6 fails') 
if (not(-l_k4b) < 0) call nrerror('ran_init: arith assump 7 fails') 
if (not(0_k4b) >= 0) call nrerror('ran_init: arith assump 8 fails') 
if (not(l_k4b) >= 0) call nrerror('ran_init: arith assump 9 fails') 
if (lenran > 0) then 

ranseeds=>reallocate(ranseeds,length,5) 

ranv=>reallocate(ranv,length- 1 ) 

new=lenran+l 

else 

allocate(ranseeds(length,5)) 
allocate(ranv(length- 1 )) 
new=l 

amm=nearest(l .0_sp,-l .0_sp)/hgng 

if (amm*hgng >= 1.0 .or. amm*hgng <= 0.0) & 

call nrerror('ran_init: arth assump 10 fails') 

end if 

ranseeds(new: , 1 )=seq 

ranseeds(new: ,2 : 5 )=spread(arth(new s 1 ,size(ranseeds(new: , 1 ))),2 ,4) 
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doj=l,4 

call ran Jiash(ranseeds(new: ,j ),ranseeds(new: ,j + 1 )) 

end do 

where (ranseeds(new:,l :3) < 0) & 

ranseeds(new:, 1 :3)=not(ranseeds(new:, 1 :3)) 
where (ranseeds(new:,4:5) — 0) ranseeds(new:,4:5)=l 
if (new =1) then 

iranO=ranseeds( 1,1) 

jranO=ranseeds(l ,2) 

kranO=ranseeds( 1,3) 

mranO=ranseeds( 1 ,4) 

nranO=ranseeds(l ,5) 

rans=nranO 

end if 

if (length > 1) then 

iran => ranseeds(2:,l) 
jran => ranseeds(2:,2) 
kran => ranseeds(2:,3) 
mran => ranseeds(2:,4) 
nran => ranseeds(2 : , 5 ) 
ranv = nran 

end if 

lenran=length 

END SUBROUTINE ranjnit 

SUBROUTINE ran_deallocate 
if (lenran > 0) then 

deallocate(ranseeds,ranv) 

nullify^anseeds^anv^iranjran^anjmranjnran) 

lenran = 0 

end if 

END SUBROUTINE ran_deallocate 

SUBROUTINE ran_seed(sequence,size,put,get) 
IMPLICIT NONE 

INTEGER, OPTIONAL, INTENT(IN) :: sequence 
INTEGER, OPTIONAL, INTENT(OUT) :: size 
INTEGER, DIMENSION0), OPTIONAL, INTENT(IN) :: put 
INTEGER, DIMENSION^, OPTIONAL, INTENT(OUT) :: get 
if (present(size)) then 

size=5* lenran 
else if (present(put)) then 

if (lenran = 0) RETURN 

ranseeds=reshape(put,shape(ranseeds)) 

where (ranseeds(:,l:3) < 0) ranseeds(:,l:3)=not(ranseeds(:,l:3)) 
where (ranseeds(:,4:5) == 0) ranseeds(:,4:5)=l 
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iranO=ranseeds(l,l) 
jranO=ranseeds( 1 ,2) 
kranO=ranseeds( 1,3) 
mranO=ranseeds( 1 ,4) 
nranO=ranseeds( 1 ,5) 
else if (present(get)) then 

if(lenran = 0) RETURN 

ranseeds(l,l:5)=(/ iranO,jranO,kranO,mranO,nranO /) 
get=reshape(ranseeds,shape(get)) 
else if (present(sequence)) then 
call ran_deallocate 
seq=sequence 

end if 

END SUBROUTINE ran_seed 

!BL 

SUBROUTINE ran_hash_s(il,ir) 
IMPLICIT NONE 

INTEGER(K4B), INTENT(INOUT) :: il,ir 

INTEGER(K4B) :: isj 

doj=l,4 

is=ir 

ir=ieor(ir,ishft(ir,5))+1422217823 
ir=ieor(ir,ishft(ir,-l 6))+l 842055030 
ir=ieor(ir,ishft(ir,9))+8056778 1 
ir=ieor(il,ir) 
il=is 

end do 

END SUBROUTINE ran_hash_s 

!BL 

SUBROUTINE ran_hash_v(il,ir) 
IMPLICIT NONE 

INTEGER(K4B), DIMENSION(:), INTENT(INOUT) :: il, 
INTEGER(K4B), DIMENSION(size(il)) :: is 
INTEGER(K4B) :: j 
doj=l,4 

is=ir 

ir=ieor(ir,ishft(ir,5))+ 1 4222 1 7823 
ir=ieor(ir,ishft(ir,-l 6))+ 1 842055030 
ir=ieor(ir,ishft(ir,9))+8056778 1 
ir=ieor(il,ir) 
il=is 

end do 

END SUBROUTINE ran_hash_v 
END MODULE ran state 
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SUBROUTINE ranl_s(harvest) 
USE nrtype 

USE ran_state, ONLY: K4B,amm,lenran,ran_init, & 

iranO jranO,kranO,nranO,mranO,rans 
IMPLICIT NONE 

REAL(SP), INTENT(OUT) :: harvest 
if (lenran < 1) call ran_init(l) 
rans=iranO-kranO 

if (rans < 0) rans=rans+2147483579_k4b 

iranO=jranO 

jranO=kranO 

kranO=rans 

nranO=ieor(nranO ,ishft(nranO, 1 3)) 
nranO=ieor(nranOjshft(nranO,- 1 7)) 
nran0=ieor(nran0 5 ishft(nran0,5)) 
if (nranO = 1 ) nran0=270369_k4b 
mranO=ieor (mranO , i shft(mranO , 5 )) 
mranO=ieor(mran0 5 ishft(mranO s - 13)) 
mran0=ieor(mran0,ishft(mran0,6)) 
rans=ieor(nranO 5 rans)+mran0 
harvest=amm*merge(rans,not(rans), rans<0-) - ; 
END SUBROUTINE ranl_s 

SUBROUTINE ranl_v(harvest) 
USE nrtype 

USE ran_state, ONLY: K4B,amm,lenran,ran_init, & 

iranjran,kran,nran 5 mran 5 ranv 
IMPLICIT NONE 

REAL(SP), DIMENSION(:) 5 INTENT(OUT) :: harvest 

INTEGER(K4B)::n 

n=size(harvest) 

if (lenran < n-H) call ran_init(n+l) 
ranv(l :n)=iran(l :n)-kran(l :n) 

where (ranv(l:n) < 0) ranv(l :n)=ranv(l :n)+2 147483 5 79_k4b 

iran(l:n)=jran(l:n) 

jran(l:n)=kran(l:n) 

kxan(l :n)=ranv(l :n) 

nran(l :n)=ieor(nran(l :n),ishft(nran(l :n),13)) 

nran(l :n)=ieor(nran(l :n),ishft(nran(l :n) 5 -17)) 

nran(l :n)=ieor(nran(l :n) 5 ishft(nran(l :n),5)) 

where (nran(l:n) == 1) nran(l:n)=270369_k4b 

mran(l :n)=ieor(mran(l :n) ? ishft(mran(l;n) 3 5)) 

mran(l :n)=ieor(mran(l :n),ishft(mran(l :n),-13)) 

mran(l :n)=ieor(mran(l :n),ishft(mran(l :n),6)) 

ranv(l :n)=ieor(nran(l :n) ? ranv(l :n))+mran(l :n) 

harvest=amm : * , merge(ranv(l:n) 5 not(ranv(l:n)), ranv(l:n)<0 ) 

END SUBROUTINE rani v 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

\*^*^*^L>i,*^ ************************ ******** 

! Time-stamp: <98/06/29 13:57:59 ayahil> 

!!! Sample characteristics: standard deviation of the variables and their 
! ! ! lambda noise estimates. 

SUBROUTINE Sample( & 

& In, & ! Lambda noise estimates squared 

& r, & ! Return data 

& std, & ! Standard deviations 

&w& ! Weights 

&) 



USE Nrtype 

USE Nrutil, ONLY: Assert eq 
USE Parm, ONLY: n, p 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:) :: w 
REAL(sp), INTENT(in), DIMENSION(:,:) :: r 
REAL(sp), INTENT(out), DIMENSION^) :: In, std 

! Locals 

INTEGER :: chk 

LOGICAL, DIMENSION(n,p) :: msk 
! Check sizes 

chk = Assert_eq( n, SIZE(r,l), SIZE(w,l), ' Sample-n' ) 

chk = Assert_eq( p, SIZE(ln), SIZE(std), SIZE(r,2), ' Sample-p' ) 

! Data mask 
msk = r /= -999.0_sp 

! Verify that the weights are non-negative 
IF( ANY( w < 0.0_sp ) ) STOP 'The weights may not be negative' 

! Sample variance of variables 
In = SUM( SPREAD( w, DIM=2, NCOPIES=p ), DIM=1, MASK=msk ) 
std = SQRT( SUM( SPREAD( w, DIM=2, NCOPIES=p )*r**2, DIM=1, MASK=msk ) & 
& /(In + EPSILON( 1 .0_sp)) ) 

! Lambda noise term 
In = ln/SQRT( (SUM( SPREAD( w**2, DIM=2, NCOPIES=p ), DIM=1, & 
& MASK=msk ) + EPSILON( 1 .0_sp)) ) 



END SUBROUTINE Sample 
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/***************** ***********************************^ 

* This file contains several wrapper function for the sentinel 

* LM libraries. The reason for these is that we do not have a LS_Handle 

* object definition and thus can't have a fortran handle (pointer) to it. 

* So, instead, a global handle to a LS_Handle object will be created 

* in the object file of this program. Every time one of the wrapper 

* functions is called, that global handle is passed in. 

* Another reason for these wrapper functions is the symbol table 

* naming conventions used by f90. An underscore (J) is pasted to 

* function identifier names. So we can't link directly to the 

* sentinel libraries. With these wrapper functions, we can solve the 

* underscore problem. 

******************************************** 

* include "lserv.h" 
LSHANDLE handle; 

/* Single-call licensing. */ 

int vlslicense_( char *feature_name, char "version) 

{ 

if (LS_SUCCESS = VLSlicense( (unsigned char *)feature_name, 
(unsigned char *) version, &handle)) 
return 1; 

else 

return 0; 

} 
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SUBROUTINE sort(arr) 

USE nrtype; USE nrutil, ONLY : swap,nrerror 

IMPLICIT NONE 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: arr 
INTEGER(I4B), PARAMETER :: NN=15, NSTACK=50 
REAL(SP) :: a 

INTEGER(I4B) :: n,k,ij,j stacker 

INTEGER(I4B), DIMENSION(NSTACK) :: istack 

n=size(arr) 

jstack=0 

1=1 

r=n 

do 

if (r-1 <NN)then 
doj=l+l,r 

a=arr(j) 
do i=j- 1,1,-1 

if (arr(i) <= a) exit 
arr(i+l)=arr(i) 

end do 
arr(i+l)=a 

end do 

if (j stack = 0) RETURN 
r=istack(j stack) 
l=istack(j stack- 1) 
jstack=jstack-2 

else 

k=(l+r)/2 

call swap(arr(k),arr(l+l)) 

call swap(arr(l),arr(r),arr(l)>arr(r)) 

call swap(arr(l+ 1 ),arr(r),arr(l+ 1 )>arr(r)) 

callswap(arr(l),arr(l+l),arr(l)>arr(l+l)) 

i=l+l 

a=arr(l+l) 
do 

do 

i=i+l 

if (arr(i) >= a) exit 

end do 
do 

j=j-l 

if (arr(j) <= a) exit 

end do 

if (j < i) exit 

call swap(arr(i) ? arr(j)) 
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end do 

arr(l+l)=arr(j) 
arr(j)=a 

jstack^jstack+2 

if Ostack > NSTACK) call nrerror('sort: NSTACK too small') 
if(r-i+l >=j-l)then 

istack(jstack)=r 

istack(j stack- l)=i 

r=j-l 

else 

istackOstack)^)-! 
istack(j stack- 1)=J 
l=i 

end if 

end if 

end do 

END SUBROUTINE sort 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/17 21:45:37 ayahil> 

!!! Optionally returns several functions of a symmetric, positive-definite, 
! ! ! matrix. 

SUBROUTINE Spd( & 



&a,& 


! Input matrix 


& adc, & 


! Cholesky decomposition of A 


& ainv, & 


! Inverse A 


&b,& 


! Input vector for solving Ax=b 


& diag, & 


! Diagonal of inverse A 


& evmin, & 


! SVD cutoff on minimum eigenvalue 


& Idet, & 


! Log-determinant of A 


&p,& 


! Diagonal of the Cholesky decomposition of A 


&X& 


! Solution of Ax=b 


&) 





USE Nr, ONLY: Choldc, Cholsl, Tqli, Tred2 
USE Nrtype 

USE Nmtil, ONLY: Assert_eq, Get_diag 
USE Utils, ONLY: Cholinv, Dmatmul_r 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION^,:) :: a 
REAL(sp), OPTIONAL, INTENT(in) :: evmin 
REAL(sp), OPTIONAL, INTENT(in), DIMENSION(:) :: b 
REAL(sp), OPTIONAL, INTENT(out) :: ldet 

REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l)) :: diag, p, x 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l),SIZE(a,2)) :: adc, ainv 
! Locals 

INTEGER ::n 

PvEAL(sp), DIMENSION(SIZE(a,l)) :: bb, d, e, pp 
REAL(sp), DIMENSION(SIZE(a,l),SIZE(a,2)) :: aa 

! Initialization 
n = Assert_eq( SIZE(a,l), SIZE(a,2), ' Spd' ) 
aa = a 

! Singular-value decomposition (SVD) 
IF( PRESENT(evmin) ) THEN 
CALL Tred2( aa, d, e ) 
CALL Tqli( d, e, aa ) 
WHERE( d > evmin ) 
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d= 1.0_sp/d 
ELSEWHERE 

d = 0.0_sp 
END WHERE 

aa = MATMUL( Dmatmul_r( aa, d ), TRANSPOSE(aa) ) 

! Inverse matrix 
IF( PRESENT(ainv) ) ainv = aa 

! Diagonal of inverse matrix 
IF( PRESENT(diag) ) diag = Get_diag( aa ) 

! Cholesky decomposition 

ELSE 
CALL Choldc( aa, pp ) 
IF( PRESENT(adc) ) adc = aa 
IF( PRESENT(p))p = pp 

! Log Determinant 
IF( PRESENT( ldet ) ) ldet = 2.0_sp*SUM( LOG( pp ) ) 

! Full matrix inversion 
IF( PRESENT(ainv) ) THEN 

CALL Cholinv( aa, pp, ainv=ainv ) 
END IF 

! Diagonal of inverse matrix 
IF( PRESENT(diag) ) THEN 

CALL Cholinv( aa, pp, diag=diag ) 
END IF 

! Solution of Ax=b 
IF( PRESENT(b) .AND. PRESENT(x) ) THEN 
IF( PRESENT(ainv) ) THEN 

x = MATMUL( ainv, b ) 
ELSE 

CALL Cholsl( aa, pp, b, x ) 
END IF 
END IF 
END IF 

END SUBROUTINE Spd 
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Copyright (C) 1998 by Algebron LLC. 

All rights reserved. 
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****** t*********************** ******* 

Time-stamp: <98/06/22 06:44:51 ayahil> 



PROGRAM Testjunc 



USE Dfport, ONLY: Dtime, Time 

USE Interfaces, ONLY: Covar, Func, Gen_covar, Gen_dev 
USE Nr, ONLY: Gasdev, Rani 
USE Nrtype 

USE Nrutil, ONLY: Get_diag 

USE Parm, ONLY: diagv, iflag, k, n, norm, p, r, sm, w 

USE Ran state, ONLY: Ran seed 

USE Utils, ONLY: Indgen, Wher 

IMPLICIT NONE 

! Locals 
INTEGER ::i, igrad,j,m 

INTEGER, ALLOCATABLE, DIMENSION(:) :: idx 
LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: msk 
REAL :: ta(2) 

REAL(sp) :: eps, f, fl, f2, frac, zsav 

REAL(sp), ALLOCATABLE, DIMENSION(:) :: t, xi, z 

REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: c, s, v 

! Initialization 
ALLOCATE( n, p ) 

eps = EPSILON(eps)**(l .0_sp/3.0_sp) 

CALL Ran_seed( Time() ) 
!!$ WRITE(*, , (a)') "Enter frac, igrad, k, n, p: ' 
!!$ READ(*,*) frac, igrad, k, n, p 

frac = 0.3 

igrad = 1 

k = 3 

n=100 

p = 5 

ALLOCATE( c(p,p), diagv(p), idx(p), msk(n,p), r(n,p), s(p,p), & 

& sm(n), t(p), v(p,p), w(n), xi(p*k+p), z(p*k+p) ) 
w = EXP( (Indgen(n) - n)/(0.5_sp*n) ) 
WRITE(*,*) 'Initialization:', Dtime( ta ) 

! Get the covariance matrix 
CALL Gen_covar( c, p ) 
WRITE(V) 'Gen_covar:', Dtime( ta ) 

! Get the deviates 
CALL Gen_dev( c, n, p, r ) 
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WRITE(V) 'Gen_dev:', Dtime( ta ) 

! Punch holes in the data & generate index 
! lists 

DO i= l,n 

CALL Ranl( t ) 

msk(i,:) = ( t > frac ) 

idx = Wher( msk(i,:), cnt=m ) 

ALLOCATE( sm(i)%idx(m) ) 

sm(i)%idx = idx(:m) 
END DO 
WHERE( msk ) 

r = -999.0_sp 
END WHERE 

WRITE(*,*) 'Mask:', COUNT(msk) 

! Test Func . 
CALL Rani (z(:p)) 
CALL Gasdev(z(p+1:)) 
v = Covar( z ) 
diagv = Get_diag( v ) 
WRITE(*,*) 'Initial z:', Dtime(ta) 
iflag = 0 

Flagjoop: DO WHILE( iflag < 2 ) 
iflag = iflag + 1 
DOj = 1,100 
f = Func( z ) 
END DO 

WRITE(*,*) Tunc computation:', Dtime( ta ) 
DOj = 1,100 

f = Func( z, xi ) 
END DO 

WRITE(*,*) Tunc with grad computation:',- Dtime( ta ) 

! Test gradient of Func 
Igradjest: IF( igrad > 0 ) THEN 
DOj = l,SIZE(z) 

zsav = z(j) 

z(j) = zsav + eps 

f2 = Func( z ) 

z(j) = zsav - eps 

fl = Func( z ) 

z(j) = zsav 

WRITE(*,*) j, 0.5_sp/eps*(f2 - fl)/(xi(j) + TINY(1.0_sp)) 
END DO 

! Test of diagv conservation with IFLAG=2 
Iflag_2: IF( iflag == 2 ) THEN 
WRITE(*,*) diagv 
CALLGasdev(z(p+l:)) 
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f = Func( z ) 
v = Covar( z ) 
diagv = Get_diag( v ) 
WRITE(V) diagv 
END IF Iflag_2 
END IF Igradtest 
END DO Flagjoop 

END PROGRAM Testjunc 
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I********************************** 

! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited, 
i********************************** 

! Time-stamp: <98/06/13 13:42:54 ayahil> 

PROGRAM Test_gen_covar 

USE Dfport, ONLY: Time 
USE Interfaces, ONLY: Gen_covar 
USE Nr, ONLY: Eigsrt, Tqli, Tred2 
USE Nrtype 

USE Ran_state, ONLY: Ran_seed 
IMPLICIT NONE 

! Locals 

INTEGER :: p 

REAL(sp), ALLOC ATABLE, DIMENSION^:) :: d, e 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: c 

! Initialization 
WRITE(*,'(a,$)') 'Enter p: ' 
READ(*,*) p 

ALLOCATE( d(p), e(p), c(p,p) ) 
CALL Ran_seed( Time() ) 

! Get the covariance matrix 
CALL Gen_covar( c, p ) 
WRITE(*,'(lp5el5.7)') TRANSPOSE(c) 
WRITE(*,*) 

! Compute the eigenvalues & eigenvectors 
CALL Tred2( c, d, e ) 
CALL Tqli( d, e, c ) 
CALL Eigsrt( d, c ) 
WRITE(*/(lp5el5.7)')d 

WRITE(*,*) 

WRITE(* ,'( 1 p5e 1 5 . 7)') TRANSPOSE(c) 
END PROGRAM Test_gen_covar 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 

! Time-stamp: <98/06/13 13:42:47 ayahil> 

PROGRAM Test_gen_dev 

USE Dfport, ONLY: Time 

USE Interfaces, ONLY: Gen_covar, Gen dev 

USE Nrtype 

USE Ran_state, ONLY: Ran_seed 
IMPLICIT NONE 

! Locals 

INTEGER ::n,p 
INTEGER :: i 

REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: c, x 

! Initialization 
WRITE(*,'(a,$)') 'Enter n, p: ' 
READ(*,*) n, p 
ALLOCATE( c(p,p), x(n,p) ) 
CALL Ran_seed( Time() ) 

! Get the covariance matrix 
CALL Gen_covar( c, p ) 
WRITE(*,'(lp5el5.7)') TRANSPOSE(c) 
WRITE(V) 

! Get the deviates 
CALL Gen_dev( c, n, p, x ) 
c = MATMUL( TRANSPOSE(x), x )/n 
WRITE(*,'(lp5el5.7)') TRANSPOSE(c) 
WRITE(*,*) 

END PROGRAM Test_gen_dev 
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***************************************** 

Copyright (C) 1998 by Algebron LLC. 

All rights reserved. 

Unauthorized reproduction prohibited. 
***************************************** 

Time-stamp: <98/06/26 15:58:03 ayahil> 
PROGRAM Test_gof 
USE Dfport, ONLY: Time 

USE Interfaces, ONLY: Get_gof, Gencovar, Gen_dev, Sample 
USE Nr, ONLY: Rani, Sort, Tqli, Tred2 
USE Nrtype 

USE Parm, ONLY: n, p, sm 

USE Ran_state, ONLY: Ran_seed . 
USE Utils, ONLY: Indgen, Wher ** 
IMPLICIT NONE 

! Locals 
INTEGER ::i,j,m 
INTEGER :: imc, nmc 

INTEGER, ALLOC AT ABLE, DIMENSION(:) :: tdx 
REAL(sp) :: gof, gof_ev, gof_std, frac, si ,s2, tau 

REAL(sp), ALLOC ATABLE, DIMENSION^) :: chi2, d, e, In, prob, s, tr, w 
REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: r, t, v 

! Initialization 
ALLOCATE( n, p ) 

WRITE(*,"(a,$)') 'Enter frac, n, nmc, p, tau: ' 
READ(*,*) frac, n, nmc, p, tau 

ALLOCATE( chi2(n), d(p), e(p), ln(p), prob(n), r(n,p), s(p), sm(n), t(p,p), & 
& tdx(n), tr(n), v(p,p), w(n) ) 

! Weights 
w = EXP( (Indgen(n) - n)/tau ) 

! Get the covariance matrix 
CALL Gen_covar( v, p ) 
WPJTE^^lpSelS.S^v 
WRITE(*,*) 

! Compute eigenvalues 

t = v 

CALL Tred2( t, d, e, novectors=.TRUE. ) 
CALL Tqli( d, e ) 
CALL Sort( d ) 
WRITE(*,'(lp5el5.5)')d 
WRITE(V) 

! Monte Carlo simulations with random initial 
! seed 

CALL Ran_seed( Time() ) 
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MonteCarlo: DO imc = l,nmc 

! Get the deviates 
CALL Gen_dev( v, n, p, r ) 

! Eliminate a fraction of the deviates 

DOj = l,p 

CALLRanl(tr) 

WHERE( tr < frac ) 
r(: j) = -999.0_sp 

END WHERE 
END DO 

! Index lists for valid returns by date 

DOi= l,n 

tdx = Wher( r(i,:) /= -999.0_sp, cnt=m ) 

ALLOCATE( sm(i)%idx(m) ) 

sm(i)%idx = tdx(:m) 
END DO 

! Compute the sample characteristics 
CALL Sample( In, r, s, w ) 

! Compute the chi-squared 
gof = Get_gof( chi2, gof ev, gof_std, prob, r, v, w ) 
WRITE(8,*) gof 
si = sl + gof 
s2 = s2 + gof**2 
END DO Monte_Carlo 

! Mean and std of gof 

sl = sl/nmc 

s2 = SQRT( (s2 - nmc*sl**2)/(nmc - 1) ) 
WRITE(V) n, gof_ev, gof_std, sl, s2 

END PROGRAM Test_gof 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited, 
j***************************************** 

! Time-stamp: <98/06/17 21:45:29 ayahil> 
PROGRAM Test_spd 

USE Dfport, ONLY: Time 
USE Interfaces, ONLY: Gen_covar 
USE Nr, ONLY: Rani, Tqli, Tred2 
USE Nrtype 

USE Nrutil, ONLY: Get_diag 
USE Ran_state, ONLY: Ran_seed 
USE Utils, ONLY: Spd 
IMPLICIT NONE 

! Parameters 
INTEGER, PARAMETER :: p=5 
! Locals 

REAL(sp) :: ldet 

REAL(sp), DIMENSIONS) :: b, d, diag, e, x 
REAL(sp), DIMENSION(p,p) :: a, ainv, t 

! Initialization 
CALL Ran_seed( Time() ) 
CALL Gen_covar( a, p ) 
CALL Ranl( b ) 

! Full matrix 
CALL Spd( a, ainv=ainv, b=b, ldet=ldet, x=x ) 
WRITE(*,'(lp5el5.7)') MATMUL( ainv, a ) 
WRITE(*,*) 

WRITE(*,'(lp5el5.7)') b - MATMUL( a, x ) 
CALL Spd( a, b=b, x=x ) 
WRITECVClpSelS.?)*) b - MATMUL( a, x ) 
WPJTE(V) 
t = a 

CALL Tred2( t, d, e, no vector s=. TRUE. ) 
CALL Tqli( d, e ) 

WRITEr/apSelS.?)') ldet, ldet - SUM( LOG( d ) ), MINVAL( d ), MAXVAL( d ) 
WRITE(*,*) 

! Eigenvalue limit 
CALL Spd( a, evmin=0.0_sp ) 
WRITE(*,'(lp5el5.5)') diag, Get_diag( ainv ) 
WRITE(V) 

WRITE(*,'(lp5el5.7)') MATMUL( ainv, a ) 
WRITE(*,*) 

CALL Spd( a, ainv=ainv, diag=diag, evmin=0.5_sp ) 
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WRITE(*,'(lp5el5.5y) diag, Get_diag( ainv ) 
WRITE(V) 

WRITE(*,'(lp5el5.7y) MATMUL( ainv, a ) 
WRITE(*,*) 

END PROGRAM Test_spd 
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Copyright (C) 1998 by Mgebron LLC. 

All rights reserved. 

Unauthorized reproduction prohibited. 
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Time-stamp: <98/06/17 21:45:26 ayahil> 
PROGRAM Test_wher 

USE Utils, ONLY: Wher 
IMPLICIT NONE 

! Parameters 
INTEGER, PARAMETER :: n=5 
! Locals 

INTEGER :: cnt 

INTEGER, DIMENSION(n) :: i 

LOGICAL, DIMENSION(n) :: mask 

mask = (/.TRUE.,.TRUE.,.FALSE.,.FALSE.,.TRUE./) 
WRITE(*,*) mask 

WRITE(*,*) Wher(mask,cnt=cnt), cnt 
END 
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SUBROUTINE tqli(d,e,z) 

USE nrtype; USE nrutil, ONLY : assert_eq,nrerror 

USE nr, ONLY : pythag 

IMPLICIT NONE 

REAL(SP), DIMENSIONC), INTENT(INOUT) :: d,e 
REAL(SP), DIMENSIONC,:), OPTIONAL, INTENT(INOUT) :: z 
INTEGER(I4B) :: i,iter,l,m,n,ndum 
REAL(SP) :: b,c,dd,f,g,p,r,s 
REAL(SP), DIMENSION(size(e)) :: ff 
n=assert_eq(size(d),size(e),'tqli : n') 

if (present(z)) ndum=assert_eq(n,size(z,l),size(z,2),'tqli: ndum') 

e(:)=eoshift(e(:),l) 

do 1=1, n 

iter=0 
iterate: do 

do m=l,n-l 

dd=abs(d(m))+abs(d(m+l)) 
if (abs(e(m))+dd = dd) exit 

end do 

if (m = 1) exit iterate 

if (iter = 30) call nrerror('too many iterations in tqli') 
iter=iter+l 

g=(d(l+l)-d(l))/(2.0_sp*e(l)) 

r=pythag(g,1.0_sp) 

g=d(m)-d(l)+e(l)/(g+sign(r,g)) 

s=1.0 

c=1.0 

p=0.0 

do i=m- 1,1,-1 

f=s*e(i) 

b=c*e(i) 

r=pythag(f,g) 

e(i+l)=r 

if(r = 0.0) then 

d(i+l)=d(i+l)-p 

e(m)=0.0 

cycle iterate 

end if 

s=f/r 

c=g/r 

g=d(i+l)-p 

r=(d(i)-g)*s+2.0_sp*c*b 
p=s*r 

d(i+l)=g+p 
g=c*r-b 

if (present(z)) then 
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ff(l:n)=z(l:n,i+l) 

z(l :n,i+l)=s*z(l :n,i)+c*ff(l :n) 

z(l:n,i)=c*z(l:n,i)-s*ff(l:n) 

end if 

end do 
d(l)=d(l)-p 

e(D=g 
e(m)=0.0 
end do iterate 

end do 

END SUBROUTINE tqli 
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Copyright (C) 1998 by Algebron LLC. 
All rights reserved. 
Unauthorized reproduction prohibited. 

Time-stamp: <98/05/06 10:54:12 ayahil> 

FUNCTION Trace( a ) RESULT( out ) 

USE Nrtype 

USE Nrutil, ONLY: Get_diag 
IMPLICIT NONE 

! Arguments 
REAL(sp), INTENT(in), DIMENSION(:,:) ::.a 
REAL(sp) :: out 

! Locals 

out = SUM( Get_diag( a ) ) 
END FUNCTION Trace 
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SUBROUTINE tred2(a,d,e,novectors) 
USE nrtype; USE nrutil, ONLY : assert_eq,outerprod 
IMPLICIT NONE 

REAL(SP), DIMENSIONC,:), INTENT(INOUT) :: a 

REAL(SP), DIMENSIONC), INTENT(OUT) :: d,e 

LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors 

INTEGER(I4B) :: ij,l,n 

REAL(SP) :: f,g,h,hh,scale 

REAL(SP), DIMENSION(size(a,l)) :: gg 

LOGIC AL(LGT), SAVE :: yesvec=. true. ' 

n=assert_eq(size(a, 1 ),size(a,2),size(d),size(e),'tred2') 

if (present(novectors)) then 

yesvec=.not. novectors 
else 

yesvec=.true. 
end if 

do i=n,2,-l 
l=i-l 
h=0.0 

if(l> l)then 

scale=sum(abs(a(i,l :1))) 
if (scale = 0.0) then 
e(i)=a(i,l) 

else 

a(i,l:l)=a(i,l:l)/scale 
h=sum(a(i,l:l)**2) 
f^a(i,l) 

g=-sign(sqrt(h),f) 
e(i)=scale*g 
h=h-f*g 
a(i,l)=f-g 

if (yesvec) a(l:l,i)=a(i,l:l)/h 
doj=l,l 

eO)=(dot_product(a(j,l :j),a(i,l :j)) & 
+dot_product(a(j+l :l,j),a(i j+ 1 :l)))/h 

end do 

f=dot_product(e(l :l),a(i, 1 :1)) 
hh=f/(h+h) 

e(l:l)=e(l:l)-hh*a(i,l:l) 
do j=l,l 

aO,l:j)=aO,l:j)-a(i,j)*e(l:j)-e(j)*a(i ) l:j) 

end do 

end if 

else 

e(i)=a(i,l) 

end if 
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d(i)=h 

end do 

if(yesvec)d(l)=0.0 

e(l)=0.0 

do i=l,n 

if (yesvec) then 
l=i-l 

if(d(i)/= 0.0) then 

gg(l :l)=matmul(a(i,l :l),a(l =1.1:1)) 

a(l :1,1 :l)=a(l :1,1 :l)-outerprod(a(l :l,i),gg(l :1)) 

end if 

d(i)=a(i,i) 

a(i,i)=1.0 

a(i,l:l)=0.0 

a(l:l,i)=0.0 

else 

d(i)=a(i,i) 

end if 

end do 

END SUBROUTINE tred2 
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! Copyright (C) 1998 by Algebron LLC. 

! All rights reserved. 

! Unauthorized reproduction prohibited. 
i******************** ********************* 

! Time-stamp: <98/07/08 09:34:32 ayahil> 

! ! ! Interfaces for utility routines. 

MODULE Utils 

INTERFACE 
SUBROUTINE Bootstrap( freq, n, seed ) 
INTEGER, INTENT(in) :: n, seed 
INTEGER, INTENT(out), DIMENSION(n) :: freq 
END SUBROUTINE Bootstrap 
END INTERFACE 

INTERFACE 
SUBROUTINE Cholinv( a, p, ainv, diag ) 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION^:) :: a 
REAL(sp), INTENT(in), DIMENSION(:) :: p 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l),SIZE(a,2)) 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l)) :: diag 
END SUBROUTINE Cholinv 
END INTERFACE 

INTERFACE 
FUNCTION Dmatmul_l( diag, mat ) RESULT( out ) 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION(:) :: diag 
REAL(sp), INTENT(in), DIMENSION(:,:) :: mat 
REAL(sp), DIMENSION(SIZE(diag),SIZE(mat,2)) :: out 
END FUNCTION DmatmulJ 
END INTERFACE 

INTERFACE 
FUNCTION Dmatmul_r( mat, diag ) RESULT( out ) 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION(:) :: diag 
REAL(sp), INTENT(in), DIMENSION(:,:) :: mat 
REAL(sp), DIMENSION(SIZE(mat,l),SIZE(diag)) :: out 
END FUNCTION Dmatmul_r 
END INTERFACE 
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INTERFACE 
FUNCTION Findgen( n ) RESULT( out ) 
USE Nrtype 

INTEGER, INTENT(in) :: n 
REAL(sp), DIMENSION(n) :: out 
END FUNCTION Findgen 
END INTERPACE 



INTERFACE 
FUNCTION Indgen( n ) RESULT( out ) 
INTEGER, INTENT(in) :: n 
INTEGER, DIMENSION(n) :: out 
END FUNCTION Indgen 
END INTERFACE 

INTERFACE 
FUNCTION Permute( n, seed ) RESULT( out ) 
USE Nrtype 

INTEGER, INTENT(in) :: n 
INTEGER, OPTIONAL :: seed 
INTEGER, DIMENSION(n) :: out 
END FUNCTION Permute 
END INTERFACE 



INTERFACE 

SUBROUTINE Spd( a, adc, ainv, b, diag, evmin, ldet, p, x ) 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION(:,:) :: a 
REAL(sp), OPTIONAL, INTENT(in) :: evmin 
REAL(sp), OPTIONAL, INTENT(in), DIMENSION(:) :: b 
REAL(sp), OPTIONAL, INTENT(out) :: ldet 

REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l)) :: diag, p, 
REAL(sp), OPTIONAL, INTENT(out), DIMENSION(SIZE(a,l),SIZE(a,2)) 

adc, ainv 
END SUBROUTINE Spd 
END INTERFACE 

INTERFACE 
FUNCTION Trace( a ) RESULT( out ) 
USE Nrtype 

REAL(sp), INTENT(in), DIMENSION(:,:) :: a 
REAL(sp) :: out 
END FUNCTION Trace 
END INTERFACE 

INTERFACE Wher 
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FUNCTION Wher_l( mask/cnt ) RESULT( out ) 
INTEGER, OPTIONAL, INTENT(out) :: cnt 
LOGICAL, INTENT(in), DIMENSION^) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out 

END FUNCTION WherJ 

FUNCTION Wher_2( mask, cnt ) RESULT( out ) 
INTEGER, OPTIONAL, INTENT(out) :: cnt 
LOGICAL, INTENT(in), DIMENSION(:,:) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out 

END FUNCTION Wher_2 

FUNCTION Wher_3( mask, cnt ) RESULT( out ) 
INTEGER, OPTIONAL, INTENT(out) :: cnt 
LOGICAL, INTENT(in), DIMENSION(:,:,:) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out 

END FUNCTION Wher_3 
END INTERFACE 

END MODULE Utils 
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!!! IDL-like WHERE function, returning the 1-d indices where MASK is true. 
! ! ! Note that, unlike in IDL, the size of the output array is always equal to 
!!! the size of MASK, with the trailing indices filled with SIZE(MASK)+1. 

FUNCTION Wher_l( mask, cnt ) RESULT( out ) 

USE Utils, ONLY: Indgen 
IMPLICIT NONE 



INTEGER, INTENT(out), OPTIONAL :: cnt 
LOGICAL, INTENT(in), DIMENSION(:) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out- 
! Locals 

INTEGER :: i 

out = PACK( RESHAPE(Indgen(SIZE(mask)),SHAPE(mask)), MASK=mask, & 

& VECTOR=SPREAD(SIZE(mask)+l,DIM=l,NCOPIES=SIZE(mask)) ) 
IF( PRESENT(cnt) ) THEN 

cnt = COUNT(mask) 
END IF 

END FUNCTION Wher_l 

FUNCTION Wher_2( mask, cnt ) RESULT( out ) 

USE Utils, ONLY: Indgen 
IMPLICIT NONE 



INTEGER, INTENT(out), OPTIONAL :: cnt 
LOGICAL, INTENT(in), DIMENSION(:,:) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out 
! Locals 

INTEGER :: i 

out = PACK( RESHAPE(Indgen(SIZE(mask)),SHAPE(mask)), MASK=mask, & 

& VECTOR=SPREAD(SIZE(mask)+l,DIM=l,NCOPIES=SIZE(mask)) ) 
IF( PRESENT(cnt) ) THEN 

cnt = COUNT(mask) 
END IF 



! Arguments 



! Arguments 
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END FUNCTION Wher_2 ' ' 

FUNCTION Wher_3( mask, cnt ) RESULT( out ) 

USE Utils, ONLY: Indgen 
IMPLICIT NONE 

! Arguments 
INTEGER, INTENT(out), OPTIONAL :: cnt 
LOGICAL, INTENT(in), DIMENSION(:,:,:) :: mask 
INTEGER, DIMENSION(SIZE(mask)) :: out 

! Locals 

INTEGER :: i 

out = PACK( RESHAPE(Indgen(SIZE(mask)),SHAPE(mask)), MASK=mask, & 

& VECTOR=SPREAD(SIZE(mask)+l,DIM=l,NCOPIES=SIZE(mask)) ) 
IF( PRESENT(cnt) ) THEN 

cnt = COUNT(mask) 
END IF 

END FUNCTION Wher_3 
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